- GMRCIR ;SLC/JAK - IFC Request data & statistics ;03/05/02 08:20
- ;;3.0;CONSULT/REQUEST TRACKING;**22**;DEC 27, 1997
- EN ; -- main entry point for GMRC IF CONSULTS
- K GMRCSVC,GMRCSVCP
- N GMRCCK,GMRCDG,GMRCIS,GMRCSTAT
- N GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2
- I $D(GMRCREMP),$D(GMRCRF) D
- .I '$D(^GMR(123,"AIP")) D
- ..W !!,$C(7),"No entries with Remote Ordering Provider data.",!
- ..S GMRCQUT=1
- .E D
- ..N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- ..S DIR(0)="PO^4:EMQ"
- ..S DIR("S")="I $$STA^XUAF4(+Y)=+$$STA^XUAF4(+Y)"
- ..S DIR("A")="Select Requesting site"
- ..D ^DIR I $D(DIRUT) S GMRCQUT=1 Q
- ..S GMRCRF=+Y
- ..W !
- ..N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- ..S DIR(0)="FO^2:40^D UP^GMRCA2 K:'$D(^GMR(123,""AIP"",X)) X"
- ..S DIR("?")="^D HELPR^GMRCIR"
- ..S DIR("A",1)=" Enter the ENTIRE name in proper CASE, exactly as it"
- ..S DIR("A",2)=" appears in the list (including any credentials)."
- ..S DIR("A",3)=" Use copy/paste to avoid typing errors."
- ..S DIR("A",4)=" NO partial matches are done."
- ..S DIR("A",5)=" Enter ? to display a list of possible entries."
- ..S DIR("A")="Select Remote Ordering Provider"
- ..D ^DIR I $D(DIRUT) S GMRCQUT=1 Q
- ..D UP^GMRCA2 S Y=X,GMRCREMP=Y
- .S GMRCIS="C"
- E D
- .N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- .S DIR(0)="SB^R:REQUESTING;C:CONSULTING"
- .S DIR("A")="Are you the Requesting site or the Consulting site"
- .D ^DIR I $D(DIRUT) S GMRCQUT=1 Q
- .S GMRCIS=Y
- I $D(GMRCQUT) D EXIT Q
- ;Get the statuses
- S GMRCSTAT=$$STS^GMRCPC1
- I $D(GMRCQUT) D EXIT Q
- I $D(GMRCEACT),$L(GMRCEACT) D I '$D(^GMR(123.5,$G(GMRCSVC),0)) D EXIT Q
- .S GMRCSVCP=GMRCEACT
- .S GMRCSVC=$O(^GMR(123.5,"B",GMRCSVCP,0))
- .Q:'$D(^GMR(123.5,$G(GMRCSVC),0))
- .;Build service array
- .S GMRCDG=GMRCSVC
- .D SERV1^GMRCASV
- .;Set date range to ALL
- .S GMRCDT1="ALL"
- .S GMRCDT2=0
- .D LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2)
- ;If no service ask for one
- I '$L($G(GMRCSVC)) D EN^GMRCSTLM I $D(GMRCQUT) D EXIT Q
- ;Quit if no array of services
- I '$O(^TMP("GMRCSLIST",$J,0)) S GMRCQUT=1 D EXIT Q
- ;
- D EN^VALM("GMRC IF CONSULTS")
- Q
- ;
- HDR ; -- header code
- Q:$D(GMRCQUT)!'$D(GMRCCT)
- S VALMHDR(1)="IFC Requests: "_$S(GMRCIS="R":"Requesting",1:"Consulting")_" Site"
- S VALMHDR(2)="Service: "_GMRCHEAD
- S VALMHDR(3)="From: "_$G(GMRCEDT1)_" To: "_$G(GMRCEDT2)
- I $G(GMRCCTRL)=1 S VALMCAP=" "_VALMCAP
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K CNT,CTRLCOL,GMRCCT,GMRCQUT,GMRCSVC,GMRCSVCP,VALMHDR
- K GMRCEDT1,GMRCEDT2,GMRCSVNM
- K GMRCCTRL,GMRCSTAT,GMRCARRN
- K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J),^TMP("GMRCR",$J,"IFC"),^TMP("GMRCRINDEX",$J),^TMP("GMRCTOT",$J)
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- CWIDTH(GMRCCTRL) ;Prints a message about how wide the report is.
- N WIDTH
- S WIDTH=128
- I GMRCCTRL#100\10 D
- .I GMRCCTRL#100\10=1 S WIDTH=WIDTH+5
- .E S WIDTH=WIDTH+10
- I GMRCCTRL#1000\100 S WIDTH=WIDTH-6
- Q WIDTH
- ;
- PWIDTH(GMRCCTRL) ;Prints a message about how wide the report is.
- W !!,"This print out is "_$$CWIDTH(GMRCCTRL)_" columns wide."
- Q
- ;
- HELPR ;Help for Remote Ordering Provider prompt
- N GMRCRP,GMRCQUT
- S GMRCRP=""
- W @IOF
- F S GMRCRP=$O(^GMR(123,"AIP",GMRCRP)) Q:GMRCRP=""!$D(GMRCQUT) D
- .W GMRCRP,!
- .I $Y>(IOSL-4) N X,Y D W:Y @IOF I 'Y S GMRCQUT=1 Q
- ..N DIR,DIROUT,DIRUT,DTOUT,DUOUT
- ..S DIR(0)="E" D ^DIR
- I $D(GMRCQUT) Q
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- S DIR(0)="E",DIR("A")="Enter RETURN or '^' to exit" D ^DIR
- Q
- ;
- DESC ;Displays Description from Option file
- N GMRCDESC,GMRCNUM,GMRCOPT,GMRCOPTN,GMRCQUT
- S GMRCNUM=""
- S GMRCOPTN="GMRC IFC RPT CONSULTS"
- S GMRCOPT=$$FIND1^DIC(19,"","X",GMRCOPTN)
- I 'GMRCOPT Q
- S GMRCDESC=$$GET1^DIQ(19,GMRCOPT,3.5,"","GMRCDESC") ; DBIA #10075
- I '$O(GMRCDESC(0)) Q
- W @IOF F S GMRCNUM=$O(GMRCDESC(GMRCNUM)) Q:GMRCNUM=""!$D(GMRCQUT) D
- .W GMRCDESC(GMRCNUM),!
- .I $Y>(IOSL-4) N X,Y D W:+Y @IOF I '+Y S GMRCQUT=1 Q
- ..N DIR,DIROUT,DIRUT,DTOUT,DUOUT
- ..S DIR(0)="E" D ^DIR
- I $D(GMRCQUT) Q
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- S DIR(0)="E",DIR("A")="Enter RETURN or '^' to exit" D ^DIR
- Q
- ;
- PRNTONLY(GMRCCTRL) ;Option to just send the report to a device.
- N GMRCQUT,RETURN,GMRCDG,GMRCSTAT,VALMBCK
- N GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMRCIS,GMRCCK,X,Y
- S DIR(0)="SB^R:REQUESTING;C:CONSULTING"
- S DIR("A")="Are you the Requesting site or the Consulting site"
- D ^DIR Q:$D(DIRUT) S GMRCIS=Y
- ;Get the statuses
- S GMRCSTAT=$$STS^GMRCPC1
- I $D(GMRCQUT) D EXIT Q
- ;Get the service and date range.
- D EN^GMRCSTLM
- I $D(GMRCQUT) D EXIT Q
- ;Quit if no array of services
- I '$O(^TMP("GMRCSLIST",$J,0)) S GMRCQUT=1 D EXIT Q
- I '($D(GMRCCTRL)#2) S GMRCCTRL=0 ; default to just the list
- ;Get description?
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- S DIR(0)="Y",DIR("B")="NO"
- S DIR("A")="Want to view a description of the data for this report now"
- D ^DIR I $D(DIRUT) D EXIT Q
- I Y>0 D DESC
- D PWIDTH(GMRCCTRL)
- ;Get the device
- D PRNTASK^GMRCSTU
- I $D(GMRCQUT) D EXIT Q
- ;Save some things if the report is queued
- I $D(IO("Q")) D
- .S ZTSAVE("GMRCCTRL")=""
- .S ZTSAVE("GMRCIS")=""
- .S ZTSAVE("GMRCSTAT")=""
- ;Create the report if not queued
- E D ENOR^GMRCSTLM(.RETURN,GMRCDG,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCCTRL,"IFC")
- ;Print the report
- D PRNTIT^GMRCSTU("IFC","PRNTQ^GMRCIR","CONSULT/REQUEST PACKAGE PRINT INTER-FACILITY CONSULT REQUESTS FROM OPTION")
- D EXIT
- Q
- ;
- PRNTQ ;Print Queued report from ^TMP global then kill off ^TMP & ^XTMP
- ;Create the report
- N RETURN,INDEX
- D ENOR^GMRCSTLM(.RETURN,GMRCDG,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCCTRL,"IFC")
- U IO
- S INDEX=""
- F S INDEX=$O(^TMP("GMRCR",$J,TMPNAME,INDEX)) Q:INDEX="" W ^TMP("GMRCR",$J,TMPNAME,INDEX,0),!
- K ^TMP("GMRCR",$J,TMPNAME),^XTMP("GMRCR",J,DOLLARH,"PRINT"),J,DOLLARH
- D ^%ZISC
- D EXIT
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIR 5856 printed Jan 18, 2025@02:47:20 Page 2
- GMRCIR ;SLC/JAK - IFC Request data & statistics ;03/05/02 08:20
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**22**;DEC 27, 1997
- EN ; -- main entry point for GMRC IF CONSULTS
- +1 KILL GMRCSVC,GMRCSVCP
- +2 NEW GMRCCK,GMRCDG,GMRCIS,GMRCSTAT
- +3 NEW GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2
- +4 IF $DATA(GMRCREMP)
- IF $DATA(GMRCRF)
- Begin DoDot:1
- +5 IF '$DATA(^GMR(123,"AIP"))
- Begin DoDot:2
- +6 WRITE !!,$CHAR(7),"No entries with Remote Ordering Provider data.",!
- +7 SET GMRCQUT=1
- End DoDot:2
- +8 IF '$TEST
- Begin DoDot:2
- +9 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +10 SET DIR(0)="PO^4:EMQ"
- +11 SET DIR("S")="I $$STA^XUAF4(+Y)=+$$STA^XUAF4(+Y)"
- +12 SET DIR("A")="Select Requesting site"
- +13 DO ^DIR
- IF $DATA(DIRUT)
- SET GMRCQUT=1
- QUIT
- +14 SET GMRCRF=+Y
- +15 WRITE !
- +16 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +17 SET DIR(0)="FO^2:40^D UP^GMRCA2 K:'$D(^GMR(123,""AIP"",X)) X"
- +18 SET DIR("?")="^D HELPR^GMRCIR"
- +19 SET DIR("A",1)=" Enter the ENTIRE name in proper CASE, exactly as it"
- +20 SET DIR("A",2)=" appears in the list (including any credentials)."
- +21 SET DIR("A",3)=" Use copy/paste to avoid typing errors."
- +22 SET DIR("A",4)=" NO partial matches are done."
- +23 SET DIR("A",5)=" Enter ? to display a list of possible entries."
- +24 SET DIR("A")="Select Remote Ordering Provider"
- +25 DO ^DIR
- IF $DATA(DIRUT)
- SET GMRCQUT=1
- QUIT
- +26 DO UP^GMRCA2
- SET Y=X
- SET GMRCREMP=Y
- End DoDot:2
- +27 SET GMRCIS="C"
- End DoDot:1
- +28 IF '$TEST
- Begin DoDot:1
- +29 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +30 SET DIR(0)="SB^R:REQUESTING;C:CONSULTING"
- +31 SET DIR("A")="Are you the Requesting site or the Consulting site"
- +32 DO ^DIR
- IF $DATA(DIRUT)
- SET GMRCQUT=1
- QUIT
- +33 SET GMRCIS=Y
- End DoDot:1
- +34 IF $DATA(GMRCQUT)
- DO EXIT
- QUIT
- +35 ;Get the statuses
- +36 SET GMRCSTAT=$$STS^GMRCPC1
- +37 IF $DATA(GMRCQUT)
- DO EXIT
- QUIT
- +38 IF $DATA(GMRCEACT)
- IF $LENGTH(GMRCEACT)
- Begin DoDot:1
- +39 SET GMRCSVCP=GMRCEACT
- +40 SET GMRCSVC=$ORDER(^GMR(123.5,"B",GMRCSVCP,0))
- +41 if '$DATA(^GMR(123.5,$GET(GMRCSVC),0))
- QUIT
- +42 ;Build service array
- +43 SET GMRCDG=GMRCSVC
- +44 DO SERV1^GMRCASV
- +45 ;Set date range to ALL
- +46 SET GMRCDT1="ALL"
- +47 SET GMRCDT2=0
- +48 DO LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2)
- End DoDot:1
- IF '$DATA(^GMR(123.5,$GET(GMRCSVC),0))
- DO EXIT
- QUIT
- +49 ;If no service ask for one
- +50 IF '$LENGTH($GET(GMRCSVC))
- DO EN^GMRCSTLM
- IF $DATA(GMRCQUT)
- DO EXIT
- QUIT
- +51 ;Quit if no array of services
- +52 IF '$ORDER(^TMP("GMRCSLIST",$JOB,0))
- SET GMRCQUT=1
- DO EXIT
- QUIT
- +53 ;
- +54 DO EN^VALM("GMRC IF CONSULTS")
- +55 QUIT
- +56 ;
- HDR ; -- header code
- +1 if $DATA(GMRCQUT)!'$DATA(GMRCCT)
- QUIT
- +2 SET VALMHDR(1)="IFC Requests: "_$SELECT(GMRCIS="R":"Requesting",1:"Consulting")_" Site"
- +3 SET VALMHDR(2)="Service: "_GMRCHEAD
- +4 SET VALMHDR(3)="From: "_$GET(GMRCEDT1)_" To: "_$GET(GMRCEDT2)
- +5 IF $GET(GMRCCTRL)=1
- SET VALMCAP=" "_VALMCAP
- +6 QUIT
- +7 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 KILL CNT,CTRLCOL,GMRCCT,GMRCQUT,GMRCSVC,GMRCSVCP,VALMHDR
- +2 KILL GMRCEDT1,GMRCEDT2,GMRCSVNM
- +3 KILL GMRCCTRL,GMRCSTAT,GMRCARRN
- +4 KILL ^TMP("GMRCS",$JOB),^TMP("GMRCSLIST",$JOB),^TMP("GMRCR",$JOB,"IFC"),^TMP("GMRCRINDEX",$JOB),^TMP("GMRCTOT",$JOB)
- +5 QUIT
- +6 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- CWIDTH(GMRCCTRL) ;Prints a message about how wide the report is.
- +1 NEW WIDTH
- +2 SET WIDTH=128
- +3 IF GMRCCTRL#100\10
- Begin DoDot:1
- +4 IF GMRCCTRL#100\10=1
- SET WIDTH=WIDTH+5
- +5 IF '$TEST
- SET WIDTH=WIDTH+10
- End DoDot:1
- +6 IF GMRCCTRL#1000\100
- SET WIDTH=WIDTH-6
- +7 QUIT WIDTH
- +8 ;
- PWIDTH(GMRCCTRL) ;Prints a message about how wide the report is.
- +1 WRITE !!,"This print out is "_$$CWIDTH(GMRCCTRL)_" columns wide."
- +2 QUIT
- +3 ;
- HELPR ;Help for Remote Ordering Provider prompt
- +1 NEW GMRCRP,GMRCQUT
- +2 SET GMRCRP=""
- +3 WRITE @IOF
- +4 FOR
- SET GMRCRP=$ORDER(^GMR(123,"AIP",GMRCRP))
- if GMRCRP=""!$DATA(GMRCQUT)
- QUIT
- Begin DoDot:1
- +5 WRITE GMRCRP,!
- +6 IF $Y>(IOSL-4)
- NEW X,Y
- Begin DoDot:2
- +7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +8 SET DIR(0)="E"
- DO ^DIR
- End DoDot:2
- if Y
- WRITE @IOF
- IF 'Y
- SET GMRCQUT=1
- QUIT
- End DoDot:1
- +9 IF $DATA(GMRCQUT)
- QUIT
- +10 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +11 SET DIR(0)="E"
- SET DIR("A")="Enter RETURN or '^' to exit"
- DO ^DIR
- +12 QUIT
- +13 ;
- DESC ;Displays Description from Option file
- +1 NEW GMRCDESC,GMRCNUM,GMRCOPT,GMRCOPTN,GMRCQUT
- +2 SET GMRCNUM=""
- +3 SET GMRCOPTN="GMRC IFC RPT CONSULTS"
- +4 SET GMRCOPT=$$FIND1^DIC(19,"","X",GMRCOPTN)
- +5 IF 'GMRCOPT
- QUIT
- +6 ; DBIA #10075
- SET GMRCDESC=$$GET1^DIQ(19,GMRCOPT,3.5,"","GMRCDESC")
- +7 IF '$ORDER(GMRCDESC(0))
- QUIT
- +8 WRITE @IOF
- FOR
- SET GMRCNUM=$ORDER(GMRCDESC(GMRCNUM))
- if GMRCNUM=""!$DATA(GMRCQUT)
- QUIT
- Begin DoDot:1
- +9 WRITE GMRCDESC(GMRCNUM),!
- +10 IF $Y>(IOSL-4)
- NEW X,Y
- Begin DoDot:2
- +11 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +12 SET DIR(0)="E"
- DO ^DIR
- End DoDot:2
- if +Y
- WRITE @IOF
- IF '+Y
- SET GMRCQUT=1
- QUIT
- End DoDot:1
- +13 IF $DATA(GMRCQUT)
- QUIT
- +14 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +15 SET DIR(0)="E"
- SET DIR("A")="Enter RETURN or '^' to exit"
- DO ^DIR
- +16 QUIT
- +17 ;
- PRNTONLY(GMRCCTRL) ;Option to just send the report to a device.
- +1 NEW GMRCQUT,RETURN,GMRCDG,GMRCSTAT,VALMBCK
- +2 NEW GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2
- +3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMRCIS,GMRCCK,X,Y
- +4 SET DIR(0)="SB^R:REQUESTING;C:CONSULTING"
- +5 SET DIR("A")="Are you the Requesting site or the Consulting site"
- +6 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET GMRCIS=Y
- +7 ;Get the statuses
- +8 SET GMRCSTAT=$$STS^GMRCPC1
- +9 IF $DATA(GMRCQUT)
- DO EXIT
- QUIT
- +10 ;Get the service and date range.
- +11 DO EN^GMRCSTLM
- +12 IF $DATA(GMRCQUT)
- DO EXIT
- QUIT
- +13 ;Quit if no array of services
- +14 IF '$ORDER(^TMP("GMRCSLIST",$JOB,0))
- SET GMRCQUT=1
- DO EXIT
- QUIT
- +15 ; default to just the list
- IF '($DATA(GMRCCTRL)#2)
- SET GMRCCTRL=0
- +16 ;Get description?
- +17 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +18 SET DIR(0)="Y"
- SET DIR("B")="NO"
- +19 SET DIR("A")="Want to view a description of the data for this report now"
- +20 DO ^DIR
- IF $DATA(DIRUT)
- DO EXIT
- QUIT
- +21 IF Y>0
- DO DESC
- +22 DO PWIDTH(GMRCCTRL)
- +23 ;Get the device
- +24 DO PRNTASK^GMRCSTU
- +25 IF $DATA(GMRCQUT)
- DO EXIT
- QUIT
- +26 ;Save some things if the report is queued
- +27 IF $DATA(IO("Q"))
- Begin DoDot:1
- +28 SET ZTSAVE("GMRCCTRL")=""
- +29 SET ZTSAVE("GMRCIS")=""
- +30 SET ZTSAVE("GMRCSTAT")=""
- End DoDot:1
- +31 ;Create the report if not queued
- +32 IF '$TEST
- DO ENOR^GMRCSTLM(.RETURN,GMRCDG,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCCTRL,"IFC")
- +33 ;Print the report
- +34 DO PRNTIT^GMRCSTU("IFC","PRNTQ^GMRCIR","CONSULT/REQUEST PACKAGE PRINT INTER-FACILITY CONSULT REQUESTS FROM OPTION")
- +35 DO EXIT
- +36 QUIT
- +37 ;
- PRNTQ ;Print Queued report from ^TMP global then kill off ^TMP & ^XTMP
- +1 ;Create the report
- +2 NEW RETURN,INDEX
- +3 DO ENOR^GMRCSTLM(.RETURN,GMRCDG,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCCTRL,"IFC")
- +4 USE IO
- +5 SET INDEX=""
- +6 FOR
- SET INDEX=$ORDER(^TMP("GMRCR",$JOB,TMPNAME,INDEX))
- if INDEX=""
- QUIT
- WRITE ^TMP("GMRCR",$JOB,TMPNAME,INDEX,0),!
- +7 KILL ^TMP("GMRCR",$JOB,TMPNAME),^XTMP("GMRCR",J,DOLLARH,"PRINT"),J,DOLLARH
- +8 DO ^%ZISC
- +9 DO EXIT
- +10 QUIT
- +11 ;