GMRCYP31 ;SLC/JFR - POST-INIT FOR PATCH 31; 2/04/03 08:02
;;3.0;CONSULT/REQUEST TRACKING;**31,32**;DEC 27, 1997
;
; Re-distributed with GMRC*3*32 to address error with no records
; to print when sent to a printer.
Q
POST ;
N %ZIS,GMRCQT,POP
W !!,"This report should be sent to a printer",!
S %ZIS="" D ^%ZIS
I POP Q
I $D(IO("Q")) D Q
. N ZTRTN,ZTDTH,ZTIO,ZTSAVE,ZTDESC
. S ZTRTN="POST1^GMRCYP31",ZTIO=ION,ZTDTH=$H
. S ZTDESC="GMRC*3*31 Post-Install Report"
. D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q
. W !,"REPORT TASKED TO PRINT!"
. Q
D POST1
Q
POST1 ; START POST-INIT
N GMRCO,GMRCISIT,GMRCRO
S GMRCISIT=0
F S GMRCISIT=$O(^GMR(123,"AIFC",GMRCISIT)) Q:'GMRCISIT D
. S GMRCRO=0
. F S GMRCRO=$O(^GMR(123,"AIFC",GMRCISIT,GMRCRO)) Q:'GMRCRO D
.. S GMRCO=$O(^GMR(123,"AIFC",GMRCISIT,GMRCRO,0))
.. I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D
... D ACTS(GMRCO)
... I $D(^TMP("GMRCYP31",$J,GMRCISIT,GMRCO)) D
.... S ^TMP("GMRCYP31",$J,GMRCISIT,GMRCO)=""
.. Q
. Q
D PRINT
Q
;
ACTS(CSLT) ;loop activities and see if there is a remote FWD or SF update
;CSTL = ien from file 123
N ACTV
S ACTV=0
F S ACTV=$O(^GMR(123,CSLT,40,ACTV)) Q:'ACTV D
. N ACTYPE
. S ACTYPE=$P(^GMR(123,CSLT,40,ACTV,0),U,2)
. Q:ACTYPE'=17&(ACTYPE'=4) ;only FWD and SF are affected
. Q:'$D(^GMR(123,CSLT,40,ACTV,2)) ;only remote activities
. Q:'$O(^GMR(123,CSLT,40,ACTV,1,1)) ;only comments >1 line long
. N SITE
. S SITE=$P(^GMR(123,CSLT,0),U,23)
. S ^TMP("GMRCYP31",$J,SITE,CSLT,ACTV,0)=""
Q
;
PRINT ; loop the ^TMP global and write records
; ask device and queue if needed
;
;I $D(ZTQUEUED) S ZTREQ="@"
N GMRCCT,TAB,GMRCDA,GMRCSIT,ACT,REMNUM,GMRCPG
U IO
S GMRCPG=1
D HDR(.GMRCPG)
I '$O(^TMP("GMRCYP31",$J,0)) D D ^%ZISC,HOME^%ZIS Q
. W !,"No records to report"
. I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" D ^DIR
. Q
S TAB=$$REPEAT^XLFSTR(" ",29)
W !,"No cleanup or modification should be made to Inter-facility consults that are "
W !,"identified with extraneous comments at this time. Patch GMRC*3*32 will outline"
W !,"the processes that should be utilized to properly accomplish these corrections."
W !,$$REPEAT^XLFSTR("*",79)
W !!
S GMRCSIT=0
F S GMRCSIT=$O(^TMP("GMRCYP31",$J,GMRCSIT)) Q:'GMRCSIT D
. S GMRCDA=0
. F S GMRCDA=$O(^TMP("GMRCYP31",$J,GMRCSIT,GMRCDA)) Q:'GMRCDA D
.. I (IOSL-$Y)<7 D HDR(.GMRCPG) I 'GMRCPG S GMRCDA=999999999 Q
.. N PTNM,PTSSN,REMSIT
.. S PTNM="Patient name: "_$$GET1^DIQ(123,GMRCDA,.02,"E")
.. S PTSSN="SSN: "_$$GET1^DIQ(2,$P(^GMR(123,GMRCDA,0),U,2),.09)
.. S REMSIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCDA,0),U,23),.01)
.. S REMNUM=$P(^GMR(123,GMRCDA,0),U,22)
.. I GMRCPG>2 W !,$$REPEAT^XLFSTR("*",78)
.. W !,"Consult #: ",GMRCDA
.. W !,PTNM,?50,PTSSN
.. W !,"Receiving Site: ",REMSIT,?50,"Remote Consult #: ",REMNUM
.. W !!,$$CJ^XLFSTR("Activities for Review",78)
.. W !,$$CJ^XLFSTR("*********************",78)
.. I (IOSL-$Y)<4 D HDR(.GMRCPG) I 'GMRCPG S GMRCDA=999999999 Q
.. W !,"Facility"
.. W !," Activity",?25,"Date/Time/Zone",$E(TAB,1,6)
.. W "Responsible Person",$E(TAB,1,2),"Entered By"
.. W !,$$REPEAT^XLFSTR("-",79)
.. S ACT=0
.. F S ACT=$O(^TMP("GMRCYP31",$J,GMRCSIT,GMRCDA,ACT)) Q:'ACT D
... N GMRCCT S GMRCCT=1
... I (IOSL-$Y)<6 D HDR(.GMRCPG,GMRCDA) I 'GMRCPG D Q
.... S (ACT,GMRCDA)=9999999999
... W !,?11,"Act. #:",ACT
... D BLDALN^GMRCSLM4(GMRCDA,ACT)
... N I S I=0
... F S I=$O(^TMP("GMRCR",$J,"DT",I)) Q:'I D
.... I (IOSL-$Y)<5 D HDR(.GMRCPG,GMRCDA) I 'GMRCPG D Q
..... S (I,ACT,GMRCDA)=9999999999
.... W !,$G(^TMP("GMRCR",$J,"DT",I,0))
... K ^TMP("GMRCR",$J,"DT")
.. W !
.. Q
. Q
D ^%ZISC,HOME^%ZIS
D EXIT
Q
;
HDR(PAGE,CSLT) ;print a new header
; PAGE = next page number
; CSLT = consult ien working on
;
I $E(IOST,1,2)="C-",PAGE>1 D I 'PAGE Q
. N DIR,DIROUT,DIRUT,DTOUT,DUOUT
. S DIR(0)="E" D ^DIR
. I $D(DIRUT) S PAGE=0
W @IOF
W !,"GMRC*3*31 Post-Install",?69,"Page: ",PAGE
W !,$$REPEAT^XLFSTR("-",79)
I $D(CSLT) D
. N TEXT
. S TEXT="Consult # "_CSLT_" cont'd."
. W !,$$CJ^XLFSTR(TEXT,80)
. W !
S PAGE=PAGE+1
Q
EXIT ; clean up
K ^TMP("GMRCYP31",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCYP31 4230 printed Dec 13, 2024@01:47:53 Page 2
GMRCYP31 ;SLC/JFR - POST-INIT FOR PATCH 31; 2/04/03 08:02
+1 ;;3.0;CONSULT/REQUEST TRACKING;**31,32**;DEC 27, 1997
+2 ;
+3 ; Re-distributed with GMRC*3*32 to address error with no records
+4 ; to print when sent to a printer.
+5 QUIT
POST ;
+1 NEW %ZIS,GMRCQT,POP
+2 WRITE !!,"This report should be sent to a printer",!
+3 SET %ZIS=""
DO ^%ZIS
+4 IF POP
QUIT
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 NEW ZTRTN,ZTDTH,ZTIO,ZTSAVE,ZTDESC
+7 SET ZTRTN="POST1^GMRCYP31"
SET ZTIO=ION
SET ZTDTH=$HOROLOG
+8 SET ZTDESC="GMRC*3*31 Post-Install Report"
+9 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
QUIT
+10 WRITE !,"REPORT TASKED TO PRINT!"
+11 QUIT
End DoDot:1
QUIT
+12 DO POST1
+13 QUIT
POST1 ; START POST-INIT
+1 NEW GMRCO,GMRCISIT,GMRCRO
+2 SET GMRCISIT=0
+3 FOR
SET GMRCISIT=$ORDER(^GMR(123,"AIFC",GMRCISIT))
if 'GMRCISIT
QUIT
Begin DoDot:1
+4 SET GMRCRO=0
+5 FOR
SET GMRCRO=$ORDER(^GMR(123,"AIFC",GMRCISIT,GMRCRO))
if 'GMRCRO
QUIT
Begin DoDot:2
+6 SET GMRCO=$ORDER(^GMR(123,"AIFC",GMRCISIT,GMRCRO,0))
+7 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)="P"
Begin DoDot:3
+8 DO ACTS(GMRCO)
+9 IF $DATA(^TMP("GMRCYP31",$JOB,GMRCISIT,GMRCO))
Begin DoDot:4
+10 SET ^TMP("GMRCYP31",$JOB,GMRCISIT,GMRCO)=""
End DoDot:4
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 DO PRINT
+14 QUIT
+15 ;
ACTS(CSLT) ;loop activities and see if there is a remote FWD or SF update
+1 ;CSTL = ien from file 123
+2 NEW ACTV
+3 SET ACTV=0
+4 FOR
SET ACTV=$ORDER(^GMR(123,CSLT,40,ACTV))
if 'ACTV
QUIT
Begin DoDot:1
+5 NEW ACTYPE
+6 SET ACTYPE=$PIECE(^GMR(123,CSLT,40,ACTV,0),U,2)
+7 ;only FWD and SF are affected
if ACTYPE'=17&(ACTYPE'=4)
QUIT
+8 ;only remote activities
if '$DATA(^GMR(123,CSLT,40,ACTV,2))
QUIT
+9 ;only comments >1 line long
if '$ORDER(^GMR(123,CSLT,40,ACTV,1,1))
QUIT
+10 NEW SITE
+11 SET SITE=$PIECE(^GMR(123,CSLT,0),U,23)
+12 SET ^TMP("GMRCYP31",$JOB,SITE,CSLT,ACTV,0)=""
End DoDot:1
+13 QUIT
+14 ;
PRINT ; loop the ^TMP global and write records
+1 ; ask device and queue if needed
+2 ;
+3 ;I $D(ZTQUEUED) S ZTREQ="@"
+4 NEW GMRCCT,TAB,GMRCDA,GMRCSIT,ACT,REMNUM,GMRCPG
+5 USE IO
+6 SET GMRCPG=1
+7 DO HDR(.GMRCPG)
+8 IF '$ORDER(^TMP("GMRCYP31",$JOB,0))
Begin DoDot:1
+9 WRITE !,"No records to report"
+10 IF $EXTRACT(IOST,1,2)="C-"
NEW DIR
SET DIR(0)="E"
DO ^DIR
+11 QUIT
End DoDot:1
DO ^%ZISC
DO HOME^%ZIS
QUIT
+12 SET TAB=$$REPEAT^XLFSTR(" ",29)
+13 WRITE !,"No cleanup or modification should be made to Inter-facility consults that are "
+14 WRITE !,"identified with extraneous comments at this time. Patch GMRC*3*32 will outline"
+15 WRITE !,"the processes that should be utilized to properly accomplish these corrections."
+16 WRITE !,$$REPEAT^XLFSTR("*",79)
+17 WRITE !!
+18 SET GMRCSIT=0
+19 FOR
SET GMRCSIT=$ORDER(^TMP("GMRCYP31",$JOB,GMRCSIT))
if 'GMRCSIT
QUIT
Begin DoDot:1
+20 SET GMRCDA=0
+21 FOR
SET GMRCDA=$ORDER(^TMP("GMRCYP31",$JOB,GMRCSIT,GMRCDA))
if 'GMRCDA
QUIT
Begin DoDot:2
+22 IF (IOSL-$Y)<7
DO HDR(.GMRCPG)
IF 'GMRCPG
SET GMRCDA=999999999
QUIT
+23 NEW PTNM,PTSSN,REMSIT
+24 SET PTNM="Patient name: "_$$GET1^DIQ(123,GMRCDA,.02,"E")
+25 SET PTSSN="SSN: "_$$GET1^DIQ(2,$PIECE(^GMR(123,GMRCDA,0),U,2),.09)
+26 SET REMSIT=$$GET1^DIQ(4,$PIECE(^GMR(123,GMRCDA,0),U,23),.01)
+27 SET REMNUM=$PIECE(^GMR(123,GMRCDA,0),U,22)
+28 IF GMRCPG>2
WRITE !,$$REPEAT^XLFSTR("*",78)
+29 WRITE !,"Consult #: ",GMRCDA
+30 WRITE !,PTNM,?50,PTSSN
+31 WRITE !,"Receiving Site: ",REMSIT,?50,"Remote Consult #: ",REMNUM
+32 WRITE !!,$$CJ^XLFSTR("Activities for Review",78)
+33 WRITE !,$$CJ^XLFSTR("*********************",78)
+34 IF (IOSL-$Y)<4
DO HDR(.GMRCPG)
IF 'GMRCPG
SET GMRCDA=999999999
QUIT
+35 WRITE !,"Facility"
+36 WRITE !," Activity",?25,"Date/Time/Zone",$EXTRACT(TAB,1,6)
+37 WRITE "Responsible Person",$EXTRACT(TAB,1,2),"Entered By"
+38 WRITE !,$$REPEAT^XLFSTR("-",79)
+39 SET ACT=0
+40 FOR
SET ACT=$ORDER(^TMP("GMRCYP31",$JOB,GMRCSIT,GMRCDA,ACT))
if 'ACT
QUIT
Begin DoDot:3
+41 NEW GMRCCT
SET GMRCCT=1
+42 IF (IOSL-$Y)<6
DO HDR(.GMRCPG,GMRCDA)
IF 'GMRCPG
Begin DoDot:4
+43 SET (ACT,GMRCDA)=9999999999
End DoDot:4
QUIT
+44 WRITE !,?11,"Act. #:",ACT
+45 DO BLDALN^GMRCSLM4(GMRCDA,ACT)
+46 NEW I
SET I=0
+47 FOR
SET I=$ORDER(^TMP("GMRCR",$JOB,"DT",I))
if 'I
QUIT
Begin DoDot:4
+48 IF (IOSL-$Y)<5
DO HDR(.GMRCPG,GMRCDA)
IF 'GMRCPG
Begin DoDot:5
+49 SET (I,ACT,GMRCDA)=9999999999
End DoDot:5
QUIT
+50 WRITE !,$GET(^TMP("GMRCR",$JOB,"DT",I,0))
End DoDot:4
+51 KILL ^TMP("GMRCR",$JOB,"DT")
End DoDot:3
+52 WRITE !
+53 QUIT
End DoDot:2
+54 QUIT
End DoDot:1
+55 DO ^%ZISC
DO HOME^%ZIS
+56 DO EXIT
+57 QUIT
+58 ;
HDR(PAGE,CSLT) ;print a new header
+1 ; PAGE = next page number
+2 ; CSLT = consult ien working on
+3 ;
+4 IF $EXTRACT(IOST,1,2)="C-"
IF PAGE>1
Begin DoDot:1
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+6 SET DIR(0)="E"
DO ^DIR
+7 IF $DATA(DIRUT)
SET PAGE=0
End DoDot:1
IF 'PAGE
QUIT
+8 WRITE @IOF
+9 WRITE !,"GMRC*3*31 Post-Install",?69,"Page: ",PAGE
+10 WRITE !,$$REPEAT^XLFSTR("-",79)
+11 IF $DATA(CSLT)
Begin DoDot:1
+12 NEW TEXT
+13 SET TEXT="Consult # "_CSLT_" cont'd."
+14 WRITE !,$$CJ^XLFSTR(TEXT,80)
+15 WRITE !
End DoDot:1
+16 SET PAGE=PAGE+1
+17 QUIT
EXIT ; clean up
+1 KILL ^TMP("GMRCYP31",$JOB)
+2 QUIT
