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 Sep 23, 2025@19:22:08 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 ;
