GMRCSTS1 ;SLC/JFR,MA - GROUP UPDATE OF CONSULTS cont'd ;4/18/01 10:31
;;3.0;CONSULT/REQUEST TRACKING;**8,18,21,50**;DEC 27, 1997;Build 8
; Patch 18 modified PRTTSK to stop for acknowledgement between
; printing the report and continuing with the group update.
; Patch 21 moved the ^%ZISC up a few lines to correct a problem
; of menu going to the printer
; This routine invokes IA #2638
PROCESS(GMRCCVT,GMRCMT) ;Update consult status by service and date range
N GMRCO,GMRCSTS,GMRCTRLC,GMRCORNP,GMRCDEV,GMRCFF,GMRCAD,ORIFN
N GMRCOM1,ORIFN
Q:'GMRCCVT
I '$D(^TMP("GMRCLS",$J)) Q ;no entries to update
S GMRCIEN=0 F S GMRCIEN=$O(^TMP("GMRCLS",$J,GMRCIEN)) Q:'GMRCIEN D
. Q:'$L($G(^GMR(123,GMRCIEN,0)))
. D AUDIT(GMRCIEN,+GMRCCVT,.GMRCMT)
. D STSUPD(GMRCIEN,+GMRCCVT)
. D CPRSUPDT(GMRCIEN,+GMRCCVT)
Q
PRINT(GMRCM,GMRCCVT,GMRCSVC,GMRCMT,GMRCSTRT,GMRCSTOP,GMRCDO) ;untasked print of records to update
PRTTSK ; print the report then start the processing
; GMRCM= status of records to find A:active, P:pending, B:Both
; GMRCCVT= status to update records with 1:dc, 2:complete
; GMRCSVC= IEN from file 123.5
; GMRCMT= array (passed by reference) of comment to stuff in records
; GMRCSTRT= first entry date to find/update
; GMRCSTOP= last entry date to find/update
; GMRCDO= 1:print only, 2:print and update records
; GMRCSTAT= Status of consult for the report (P,A,S)
N GMRCIEN,GMRCDFN,GMRCPG,GMRCEND,GMRCSTAT
S GMRCIEN=0
U IO
D HDR(1) S GMRCPG=2
I '$D(^TMP("GMRCLS",$J)) D D END
. W !,"No records found meeting search criteria"
F S GMRCIEN=$O(^TMP("GMRCLS",$J,GMRCIEN)) Q:'GMRCIEN!($G(GMRCEND)) D
. I $Y>(IOSL-5) D HDR(GMRCPG) Q:$G(GMRCEND) S GMRCPG=GMRCPG+1
. Q:'$G(^GMR(123,GMRCIEN,0))
. I $P(^GMR(123,GMRCIEN,0),U,12)=1!($P(^(0),U,12)=2) Q
. W !,GMRCIEN,?8,$$FMTE^XLFDT(+^GMR(123,GMRCIEN,0))
. W ?29,$E($$GET1^DIQ(2,$P(^GMR(123,GMRCIEN,0),U,2),.01),1,26)
. W ?56,$$GET1^DIQ(2,$P(^GMR(123,GMRCIEN,0),U,2),.09)
. S GMRCSTAT=+^TMP("GMRCLS",$J,GMRCIEN)
. W ?70,$S(GMRCSTAT=5:"p",GMRCSTAT=6:"a",GMRCSTAT=8:"s",1:"?")
. W " to ",$S(+GMRCCVT=1:"dc",1:"c")
D ^%ZISC
I GMRCDO=2,'$D(ZTQUEUED) D ; Not task
. S DIR(0)="S^Y:To Update;N:To Quit without Updating"
. S DIR("A")="Enter update status "
. I ($D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)) Q
. D ^DIR
. I Y="Y" D PROCESS(+GMRCCVT,.GMRCMT)
I GMRCDO=2,$D(ZTQUEUED) D PROCESS(+GMRCCVT,.GMRCMT) ; Tasked
END K ^TMP("GMRCLS",$J)
Q
;
HDR(PAGE) ; print the header for the report
I PAGE'=1,$E(IOST,1,2)["C-" N Y D I '+Y S GMRCEND=1 Q
. N DIR S DIR(0)="E" D ^DIR
W @IOF
W !,"Group status update of consults in file 123",?70,"Page: ",PAGE W:PAGE'=1 !
I PAGE=1 W !,?49,"Printed: ",$$FMTE^XLFDT($$NOW^XLFDT)
I PAGE=1 D UPDCRIT(GMRCCVT,GMRCM,GMRCSVC,.GMRCMT,GMRCSTRT,GMRCSTOP)
W !,"Consult",?70,"Status"
W !,"Number Requested Patient SSN Change"
W !,$$REPEAT^XLFSTR("-",79)
Q
GETENTS(SERV,STRDT,STPDT,SRCH) ;loop "AE" x-ref and dump into ^TMP
N IDT,IEN,STOPI,STRTI,STS,INDEX
W !!,"Searching database for entries matching search criteria",!
S STOPI=(9999999-STPDT)-1,STRTI=(9999999-STRDT)
F INDEX=1:1 Q:$P(SRCH,",",INDEX)="" D
. I $P(SRCH,",",INDEX)=+4 S SRCH="1,2,3,"
; Convert SRCH from 1,2,3 to 5,6,8 (pending,active,scheduled)
F INDEX=1:1 Q:$P(SRCH,",",INDEX)="" D
. I $P(SRCH,",",INDEX)=+1 S STS=+5 D GETDATA
. I $P(SRCH,",",INDEX)=+2 S STS=+6 D GETDATA
. I $P(SRCH,",",INDEX)=+3 S STS=+8 D GETDATA
GETDATA ; Write ^GMR(123,IEN,0) to TMP
S IDT=STOPI
F S IDT=$O(^GMR(123,"AE",SERV,+STS,IDT)) Q:'IDT!(IDT>STRTI) D
. S IEN=0 F S IEN=$O(^GMR(123,"AE",SERV,+STS,IDT,IEN)) Q:'IEN D
.. S ^TMP("GMRCLS",$J,IEN)=+STS_U_+^GMR(123,IEN,0)
.. W "."
Q
AUDIT(GMRCO,UPDSTS,GMRCOM) ;Update the processing activity of the consult
;GMRCO= IEN from file 123
;UPDSTS= 1 for DC ; 2 for COMPLETE
N DA,DIE,GMRCA,GMRCDT,GMRCSTS
S GMRCDT=$$NOW^XLFDT,GMRCA=$S(UPDSTS=1:6,1:10)
S GMRCSTS=$P(^GMR(123,GMRCO,0),U,12)
S:'$D(^GMR(123,+GMRCO,40,0)) ^(0)="^123.02DA^^"
S DA=$S($P(^GMR(123,+GMRCO,40,0),"^",3):$P(^(0),"^",3)+1,1:1),$P(^GMR(123,GMRCO,40,0),"^",3,4)=DA_"^"_DA
S DIE="^GMR(123,"_+GMRCO_",40,",DA(1)=+GMRCO
S DR=".01////^S X=GMRCDT;1////^S X=GMRCA;2////^S X=GMRCDT;3////^S X=DUZ;4////^S X=DUZ"
D ^DIE
S ^GMR(123,+GMRCO,40,DA,1,0)="^^1^1^"_GMRCDT_"^"
I $D(GMRCOM) D
. M ^GMR(123,+GMRCO,40,DA,1)=GMRCOM
I '$D(GMRCOM) D
. N COMMENT
. S COMMENT="Status updated from "
. S COMMENT=COMMENT_$P(^ORD(100.01,+GMRCSTS,0),"^",1)
. S COMMENT=COMMENT_" to "_$S(+UPDSTS=2:"COMPLETE",1:"DISCONTINUED")
. S COMMENT=COMMENT_" during group status update process."
. S ^GMR(123,+GMRCO,40,DA,1,1,0)=COMMENT
;Check for IFC and update accordingly
I $D(^GMR(123,+GMRCO,12)),$D(^(40,DA)) D TRIGR^GMRCIEVT(GMRCO,DA)
K DIE,GMRCA,GMRCDT
Q
STSUPD(GMRCO,UPDSTS) ;change status of consult to COMPLETE or DC
;GMRCO= IEN from file 123
;UPDSTS= 1 for DC ; 2 for COMPLETE
N DIE,DA,DR,GMRCLST,X
S GMRCLST=$S(UPDSTS=1:$O(^GMR(123.1,"B","DISCONTINUED",0)),UPDSTS=2:$O(^GMR(123.1,"B","COMPLETE/UPDATE",0)),1:99)
S DIE="^GMR(123,",DA=GMRCO
S DR="8////^S X=+UPDSTS;9////"_GMRCLST
D ^DIE
Q
CPRSUPDT(GMRCO,UPDSTS) ;Update CPRS order with new status
;GMRCO= IEN from file 123
;UPDSTS= status to update CPRS with
N GMRCDFN,CTRLCODE
S GMRCDFN=$P(^GMR(123,GMRCO,0),"^",2)
S CTRLCODE=$S(UPDSTS=1:"OD",1:"RE")
; send HL7 message to CPRS to update order status
D EN^GMRCHL7(GMRCDFN,+GMRCO,"","",CTRLCODE,DUZ,"","",1)
Q
UPDCRIT(UPD,STS,SVC,CMT,START,STOP) ;print update criteria on page 1
N INDEX,GMRCSTS
F INDEX=1:1 Q:$P(STS,",",INDEX)="" D
. I STS[+4 S GMRCSTS="Active, Pending, and Scheduled" Q
. I $P(STS,",",INDEX)=+1 S $P(GMRCSTS,",",INDEX)="Pending"
. I $P(STS,",",INDEX)=+2 S $P(GMRCSTS,",",INDEX)="Active"
. I $P(STS,",",INDEX)=+3 S $P(GMRCSTS,",",INDEX)="Scheduled"
W !,"Records will be updated for:"
W !,$$REPEAT^XLFSTR("-",78)
W !," Service: "_$$GET1^DIQ(123.5,SVC,.01)
W !," Beginning: "_$$FMTE^XLFDT(START)
W !," Ending: "_$$FMTE^XLFDT(STOP)
W !," Update: "_GMRCSTS_" "_" Consults"
W !," To: "_$S(+UPD=2:"COMPLETE",1:"DISCONTINUED")
I $D(CMT) W !," Update Comment:" D
. N I S I=0 F S I=$O(CMT(I)) Q:'I D
.. W !,CMT(I,0)
W !,$$REPEAT^XLFSTR("-",78),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCSTS1 6422 printed Sep 23, 2025@19:23:31 Page 2
GMRCSTS1 ;SLC/JFR,MA - GROUP UPDATE OF CONSULTS cont'd ;4/18/01 10:31
+1 ;;3.0;CONSULT/REQUEST TRACKING;**8,18,21,50**;DEC 27, 1997;Build 8
+2 ; Patch 18 modified PRTTSK to stop for acknowledgement between
+3 ; printing the report and continuing with the group update.
+4 ; Patch 21 moved the ^%ZISC up a few lines to correct a problem
+5 ; of menu going to the printer
+6 ; This routine invokes IA #2638
PROCESS(GMRCCVT,GMRCMT) ;Update consult status by service and date range
+1 NEW GMRCO,GMRCSTS,GMRCTRLC,GMRCORNP,GMRCDEV,GMRCFF,GMRCAD,ORIFN
+2 NEW GMRCOM1,ORIFN
+3 if 'GMRCCVT
QUIT
+4 ;no entries to update
IF '$DATA(^TMP("GMRCLS",$JOB))
QUIT
+5 SET GMRCIEN=0
FOR
SET GMRCIEN=$ORDER(^TMP("GMRCLS",$JOB,GMRCIEN))
if 'GMRCIEN
QUIT
Begin DoDot:1
+6 if '$LENGTH($GET(^GMR(123,GMRCIEN,0)))
QUIT
+7 DO AUDIT(GMRCIEN,+GMRCCVT,.GMRCMT)
+8 DO STSUPD(GMRCIEN,+GMRCCVT)
+9 DO CPRSUPDT(GMRCIEN,+GMRCCVT)
End DoDot:1
+10 QUIT
PRINT(GMRCM,GMRCCVT,GMRCSVC,GMRCMT,GMRCSTRT,GMRCSTOP,GMRCDO) ;untasked print of records to update
PRTTSK ; print the report then start the processing
+1 ; GMRCM= status of records to find A:active, P:pending, B:Both
+2 ; GMRCCVT= status to update records with 1:dc, 2:complete
+3 ; GMRCSVC= IEN from file 123.5
+4 ; GMRCMT= array (passed by reference) of comment to stuff in records
+5 ; GMRCSTRT= first entry date to find/update
+6 ; GMRCSTOP= last entry date to find/update
+7 ; GMRCDO= 1:print only, 2:print and update records
+8 ; GMRCSTAT= Status of consult for the report (P,A,S)
+9 NEW GMRCIEN,GMRCDFN,GMRCPG,GMRCEND,GMRCSTAT
+10 SET GMRCIEN=0
+11 USE IO
+12 DO HDR(1)
SET GMRCPG=2
+13 IF '$DATA(^TMP("GMRCLS",$JOB))
Begin DoDot:1
+14 WRITE !,"No records found meeting search criteria"
End DoDot:1
DO END
+15 FOR
SET GMRCIEN=$ORDER(^TMP("GMRCLS",$JOB,GMRCIEN))
if 'GMRCIEN!($GET(GMRCEND))
QUIT
Begin DoDot:1
+16 IF $Y>(IOSL-5)
DO HDR(GMRCPG)
if $GET(GMRCEND)
QUIT
SET GMRCPG=GMRCPG+1
+17 if '$GET(^GMR(123,GMRCIEN,0))
QUIT
+18 IF $PIECE(^GMR(123,GMRCIEN,0),U,12)=1!($PIECE(^(0),U,12)=2)
QUIT
+19 WRITE !,GMRCIEN,?8,$$FMTE^XLFDT(+^GMR(123,GMRCIEN,0))
+20 WRITE ?29,$EXTRACT($$GET1^DIQ(2,$PIECE(^GMR(123,GMRCIEN,0),U,2),.01),1,26)
+21 WRITE ?56,$$GET1^DIQ(2,$PIECE(^GMR(123,GMRCIEN,0),U,2),.09)
+22 SET GMRCSTAT=+^TMP("GMRCLS",$JOB,GMRCIEN)
+23 WRITE ?70,$SELECT(GMRCSTAT=5:"p",GMRCSTAT=6:"a",GMRCSTAT=8:"s",1:"?")
+24 WRITE " to ",$SELECT(+GMRCCVT=1:"dc",1:"c")
End DoDot:1
+25 DO ^%ZISC
+26 ; Not task
IF GMRCDO=2
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+27 SET DIR(0)="S^Y:To Update;N:To Quit without Updating"
+28 SET DIR("A")="Enter update status "
+29 IF ($DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT))
QUIT
+30 DO ^DIR
+31 IF Y="Y"
DO PROCESS(+GMRCCVT,.GMRCMT)
End DoDot:1
+32 ; Tasked
IF GMRCDO=2
IF $DATA(ZTQUEUED)
DO PROCESS(+GMRCCVT,.GMRCMT)
END KILL ^TMP("GMRCLS",$JOB)
+1 QUIT
+2 ;
HDR(PAGE) ; print the header for the report
+1 IF PAGE'=1
IF $EXTRACT(IOST,1,2)["C-"
NEW Y
Begin DoDot:1
+2 NEW DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:1
IF '+Y
SET GMRCEND=1
QUIT
+3 WRITE @IOF
+4 WRITE !,"Group status update of consults in file 123",?70,"Page: ",PAGE
if PAGE'=1
WRITE !
+5 IF PAGE=1
WRITE !,?49,"Printed: ",$$FMTE^XLFDT($$NOW^XLFDT)
+6 IF PAGE=1
DO UPDCRIT(GMRCCVT,GMRCM,GMRCSVC,.GMRCMT,GMRCSTRT,GMRCSTOP)
+7 WRITE !,"Consult",?70,"Status"
+8 WRITE !,"Number Requested Patient SSN Change"
+9 WRITE !,$$REPEAT^XLFSTR("-",79)
+10 QUIT
GETENTS(SERV,STRDT,STPDT,SRCH) ;loop "AE" x-ref and dump into ^TMP
+1 NEW IDT,IEN,STOPI,STRTI,STS,INDEX
+2 WRITE !!,"Searching database for entries matching search criteria",!
+3 SET STOPI=(9999999-STPDT)-1
SET STRTI=(9999999-STRDT)
+4 FOR INDEX=1:1
if $PIECE(SRCH,",",INDEX)=""
QUIT
Begin DoDot:1
+5 IF $PIECE(SRCH,",",INDEX)=+4
SET SRCH="1,2,3,"
End DoDot:1
+6 ; Convert SRCH from 1,2,3 to 5,6,8 (pending,active,scheduled)
+7 FOR INDEX=1:1
if $PIECE(SRCH,",",INDEX)=""
QUIT
Begin DoDot:1
+8 IF $PIECE(SRCH,",",INDEX)=+1
SET STS=+5
DO GETDATA
+9 IF $PIECE(SRCH,",",INDEX)=+2
SET STS=+6
DO GETDATA
+10 IF $PIECE(SRCH,",",INDEX)=+3
SET STS=+8
DO GETDATA
End DoDot:1
GETDATA ; Write ^GMR(123,IEN,0) to TMP
+1 SET IDT=STOPI
+2 FOR
SET IDT=$ORDER(^GMR(123,"AE",SERV,+STS,IDT))
if 'IDT!(IDT>STRTI)
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^GMR(123,"AE",SERV,+STS,IDT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+4 SET ^TMP("GMRCLS",$JOB,IEN)=+STS_U_+^GMR(123,IEN,0)
+5 WRITE "."
End DoDot:2
End DoDot:1
+6 QUIT
AUDIT(GMRCO,UPDSTS,GMRCOM) ;Update the processing activity of the consult
+1 ;GMRCO= IEN from file 123
+2 ;UPDSTS= 1 for DC ; 2 for COMPLETE
+3 NEW DA,DIE,GMRCA,GMRCDT,GMRCSTS
+4 SET GMRCDT=$$NOW^XLFDT
SET GMRCA=$SELECT(UPDSTS=1:6,1:10)
+5 SET GMRCSTS=$PIECE(^GMR(123,GMRCO,0),U,12)
+6 if '$DATA(^GMR(123,+GMRCO,40,0))
SET ^(0)="^123.02DA^^"
+7 SET DA=$SELECT($PIECE(^GMR(123,+GMRCO,40,0),"^",3):$PIECE(^(0),"^",3)+1,1:1)
SET $PIECE(^GMR(123,GMRCO,40,0),"^",3,4)=DA_"^"_DA
+8 SET DIE="^GMR(123,"_+GMRCO_",40,"
SET DA(1)=+GMRCO
+9 SET DR=".01////^S X=GMRCDT;1////^S X=GMRCA;2////^S X=GMRCDT;3////^S X=DUZ;4////^S X=DUZ"
+10 DO ^DIE
+11 SET ^GMR(123,+GMRCO,40,DA,1,0)="^^1^1^"_GMRCDT_"^"
+12 IF $DATA(GMRCOM)
Begin DoDot:1
+13 MERGE ^GMR(123,+GMRCO,40,DA,1)=GMRCOM
End DoDot:1
+14 IF '$DATA(GMRCOM)
Begin DoDot:1
+15 NEW COMMENT
+16 SET COMMENT="Status updated from "
+17 SET COMMENT=COMMENT_$PIECE(^ORD(100.01,+GMRCSTS,0),"^",1)
+18 SET COMMENT=COMMENT_" to "_$SELECT(+UPDSTS=2:"COMPLETE",1:"DISCONTINUED")
+19 SET COMMENT=COMMENT_" during group status update process."
+20 SET ^GMR(123,+GMRCO,40,DA,1,1,0)=COMMENT
End DoDot:1
+21 ;Check for IFC and update accordingly
+22 IF $DATA(^GMR(123,+GMRCO,12))
IF $DATA(^(40,DA))
DO TRIGR^GMRCIEVT(GMRCO,DA)
+23 KILL DIE,GMRCA,GMRCDT
+24 QUIT
STSUPD(GMRCO,UPDSTS) ;change status of consult to COMPLETE or DC
+1 ;GMRCO= IEN from file 123
+2 ;UPDSTS= 1 for DC ; 2 for COMPLETE
+3 NEW DIE,DA,DR,GMRCLST,X
+4 SET GMRCLST=$SELECT(UPDSTS=1:$ORDER(^GMR(123.1,"B","DISCONTINUED",0)),UPDSTS=2:$ORDER(^GMR(123.1,"B","COMPLETE/UPDATE",0)),1:99)
+5 SET DIE="^GMR(123,"
SET DA=GMRCO
+6 SET DR="8////^S X=+UPDSTS;9////"_GMRCLST
+7 DO ^DIE
+8 QUIT
CPRSUPDT(GMRCO,UPDSTS) ;Update CPRS order with new status
+1 ;GMRCO= IEN from file 123
+2 ;UPDSTS= status to update CPRS with
+3 NEW GMRCDFN,CTRLCODE
+4 SET GMRCDFN=$PIECE(^GMR(123,GMRCO,0),"^",2)
+5 SET CTRLCODE=$SELECT(UPDSTS=1:"OD",1:"RE")
+6 ; send HL7 message to CPRS to update order status
+7 DO EN^GMRCHL7(GMRCDFN,+GMRCO,"","",CTRLCODE,DUZ,"","",1)
+8 QUIT
UPDCRIT(UPD,STS,SVC,CMT,START,STOP) ;print update criteria on page 1
+1 NEW INDEX,GMRCSTS
+2 FOR INDEX=1:1
if $PIECE(STS,",",INDEX)=""
QUIT
Begin DoDot:1
+3 IF STS[+4
SET GMRCSTS="Active, Pending, and Scheduled"
QUIT
+4 IF $PIECE(STS,",",INDEX)=+1
SET $PIECE(GMRCSTS,",",INDEX)="Pending"
+5 IF $PIECE(STS,",",INDEX)=+2
SET $PIECE(GMRCSTS,",",INDEX)="Active"
+6 IF $PIECE(STS,",",INDEX)=+3
SET $PIECE(GMRCSTS,",",INDEX)="Scheduled"
End DoDot:1
+7 WRITE !,"Records will be updated for:"
+8 WRITE !,$$REPEAT^XLFSTR("-",78)
+9 WRITE !," Service: "_$$GET1^DIQ(123.5,SVC,.01)
+10 WRITE !," Beginning: "_$$FMTE^XLFDT(START)
+11 WRITE !," Ending: "_$$FMTE^XLFDT(STOP)
+12 WRITE !," Update: "_GMRCSTS_" "_" Consults"
+13 WRITE !," To: "_$SELECT(+UPD=2:"COMPLETE",1:"DISCONTINUED")
+14 IF $DATA(CMT)
WRITE !," Update Comment:"
Begin DoDot:1
+15 NEW I
SET I=0
FOR
SET I=$ORDER(CMT(I))
if 'I
QUIT
Begin DoDot:2
+16 WRITE !,CMT(I,0)
End DoDot:2
End DoDot:1
+17 WRITE !,$$REPEAT^XLFSTR("-",78),!
+18 QUIT
