GMRCP85 ;WAT - Post-install for GMRC*3.0*85 ;12/22/15 07:21
;;3.0;CONSULT/REQUEST TRACKING;**85**;DEC 27, 1997;Build 3
;;ICR 6257 - GMRC READ OF OR(100 GLOBAL
;;10061 VADPT (DEM and KVA)
;;10104 XLFSTR ;;10103 XLFDT ;;10141 XPDUTL ;;1131 ^XMB("NETNAME")
;;10063 ZTLOAD
;;3169 ^ORD(101.43 ;;873 ^ORD(100.98
;; ZT* TaskMan variables
Q
RECIP ;RECIPIENTS
K:$D(^XTMP("GMRCP85RECIPS")) ^XTMP("GMRCP85RECIPS")
W !,$$CJ^XLFSTR("*** REJECTED CONSULT/PROCEDURE ORDERS REPORT ",80," "),!
W $$CJ^XLFSTR("DATE DEFAULT VALUE REPORT QUESTIONS ***",80," "),!
W !,"The post-install will create the REJECTED CONSULT/PROCEDURE ORDERS",!
W "REPORT, which contains orders rejected by Consults with the message:",!
W " Code not valid for Coding System",!!
W "The installer MUST include the site's local Clinical Application Coordinators",!
W "(CACs) or other identified points-of-contact as recipients of this report.",!!
W !!,"Please select the recipients for the REJECTED CONSULT/PROCEDURE ORDERS REPORT",!
W "below."
N XMDUZ,XMDF,XMMG,X,XMOUT,XMY
S XMDUZ=DUZ
D DES^XMA21 ;ICR #10067
I $D(XMY)>9 D
.S ^XTMP("GMRCP85RECIPS",0)=$$FMADD^XLFDT(DT,31)_U_DT_U_"RECIPIENTS OF REJECTED CONSULT/PROCEDURE ORDERS REPORT"
.M ^XTMP("GMRCP85RECIPS")=XMY
Q
PRE ; pre-init
D RECIP
Q
POST ; post init
N GMRCPOST
S GMRCPOST=1
D QUEUE("find rejected gmrc orders report","ORDSRCH^GMRCP85","FILE #100 SEARCH FOR ORDERS REJECTED BY GMRC")
Q
;
RESTART ;index redux
W !,"Queueing file 100 search..."
D QUEUE("GMRC*3.0*85 file #100 search","ORDSRCH^GMRCP85","FILE #100 SEARCH FOR ORDERS REJECTED BY GMRC")
Q
QUEUE(GMRCMSG,ZTRTN,ZTDESC) ;CREATE A SPECIFIED TASK
;PARAMETERS: GMRCMSG => STRING CONTAINING THE TEXT TO OUTPUT TO THE SCREEN
; ZTRTN => STRING CONTAINING THE ROUTINE TASKMAN SHOULD EXECUTE
; ZTDESC => STRING CONTAINING THE TASK'S DESCRIPTION
N ZTDTH,ZTIO,ZTSK
D BMES^XPDUTL("Queueing "_GMRCMSG_"...")
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,0,10)
S ZTIO=""
D ^%ZTLOAD
I +$G(ZTSK)=0 D
.I $G(GMRCPOST) D BMES^XPDUTL("Unable to queue the "_GMRCMSG_"; file a Remedy ticket for assistance.")
.E W "ERROR",!,"Unable to queue the "_GMRCMSG_"; file a Remedy ticket for assistance.",!
E D
.I $G(GMRCPOST) D
..D BMES^XPDUTL("DONE - Task #"_ZTSK)
.E W "DONE",!,"Task #"_ZTSK,!
Q
;
ORDSRCH ;find rejected consult/procedure orders
K ^XTMP("GMRCP85_ORDERS")
S ^XTMP("GMRCP85_ORDERS",0)=$$FMADD^XLFDT(DT,31)_U_DT_U_"REJECTED ORDERS FOUND BY GMRC*3.0*85"
N GMRCON,GMRCPROC,DISPGRP,GMRCIFN,DCTXT,COUNT,GMRCREP,GMRCSTAT,DFN,GMRCNAME,GMRCSVC,GMRCDATE,LOOPCNT
S COUNT=1,LOOPCNT=0
S GMRCON="",GMRCON=$O(^ORD(100.98,"B","CONSULTS",""))
S GMRCPROC="",GMRCPROC=$O(^ORD(100.98,"B","PROCEDURES",""))
N STRTDATE S STRTDATE=3150901
I $D(^XTMP("GMRCP85","OR100AF","DATE")) S STRTDATE=^XTMP("GMRCP85","OR100AF","DATE") ;restart search from last date referenced
N GMRCIDX S GMRCIDX=$Q(^OR(100,"AF",STRTDATE))
F S GMRCIDX=$Q(@GMRCIDX) Q:GMRCIDX'?1"^OR(100,""AF"",".E!($G(ZTSTOP)=1) D
.S GMRCIFN=$P(GMRCIDX,",",4) Q:+$G(GMRCIFN)'>0
.S DISPGRP=$P(^OR(100,GMRCIFN,0),U,11) ;DISPLAY GROUP
.Q:DISPGRP'=GMRCON&(DISPGRP'=GMRCPROC)
.Q:$D(^OR(100,GMRCIFN,6))=0 ;not rejected
.Q:$P(^OR(100,GMRCIFN,6),U)'=7 ;REJECTED
.S DCTXT=$P(^OR(100,GMRCIFN,6),U,5) ;DC REASON TEXT
.Q:$G(DCTXT)'["Code not valid for Coding System"
.S GMRCSVC=""
.I $D(^OR(100,GMRCIFN,4.5,"ID","SERVICE")) D
..S GMRCSVC=$O(^OR(100,GMRCIFN,4.5,"ID","SERVICE",0))
..S GMRCSVC=^OR(100,GMRCIFN,4.5,GMRCSVC,1) S GMRCSVC=$P(^GMR(123.5,GMRCSVC,0),U)
.I $G(GMRCSVC)="" D
..S GMRCSVC=$$FINDSVC(.GMRCIFN) S:+$G(GMRCSVC)="" GMRCSVC="NOT FOUND"
.S GMRCNAME=$P(^OR(100,GMRCIFN,0),U,2) Q:$G(GMRCNAME)'["DPT"
.S DFN=+$G(GMRCNAME)
.D DEM^VADPT ;get pt name and last 4
.S GMRCDATE=$P(^OR(100,GMRCIFN,0),U,7) ;to service
.S ^XTMP("GMRCP85_ORDERS",VADM(1)_" ("_VA("BID")_")",COUNT)=VADM(1)_"("_VA("BID")_")"_U_GMRCSVC_U_GMRCDATE_U_GMRCIFN,COUNT=COUNT+1 ;name + last 4
.D KVA^VADPT
.S LOOPCNT=LOOPCNT+1
.I LOOPCNT#500=0,($$S^%ZTLOAD) N X S ZTSTOP=1,X=$$S^%ZTLOAD("Received shutdown request")
;SEND STATUS EMAIL
I +$G(ZTSTOP)=0 D
.S GMRCREP(1)="The file #100 search process from GMRC*3.0*85 was successfully completed."
.S GMRCREP(2)=""
.D OUTPUT
E D
.K GMRCREP
.S GMRCREP(1)="The file #100 search process from GMRC*3.0*85 has unexpectedly stopped."
.S GMRCREP(2)="If you or the system manager did not stop the process, please check the"
.S GMRCREP(3)="error log and file a Remedy ticket for assistance."
.S GMRCREP(4)=""
.S GMRCREP(5)="To requeue the cleanup/conversion process, run RESTART^GMRCP85 from the"
.S GMRCREP(6)="programmer prompt."
S GMRCSTAT=$$MAIL("GMRCREP(","PATCH GMRC*3.0*85 ORDER SEARCH STATUS",,"GMRCP85RECIPS")
I +GMRCSTAT,($G(ZTSTOP)=1) D
.S ^XTMP("GMRCP85",0)=$$FMADD^XLFDT($$NOW^XLFDT,7,0,0,0)_U_$$NOW^XLFDT_U_"GMRC*3.0*85 POST-INSTALL DATA"
.S ^XTMP("GMRCP85","OR100AF","DATE")=$P(GMRCIDX,",",3) ;capture last date referenced to restart search from.
S ZTREQ="@"
Q
FINDSVC(GMRCIFN) ; service not directly accessbile in the OR(100 entry, go find it
N GMRCSERV,GMRCODBL,GMRCPROC S GMRCSERV=""
;GMRSERV - CONSULT SERVICE
;GMRCODBL - ORDERABLE ITEM FROM OR(100
I $D(^OR(100,GMRCIFN,.1,1,0)) D
.S GMRCODBL=^OR(100,GMRCIFN,.1,1,0)
I $D(^ORD(101.43,$G(GMRCODBL),0)) D
.S GMRCODBL=$P(^ORD(101.43,$G(GMRCODBL),0),U,2) ; service IEN;99CON or procedure IEN;99PRC
.I $G(GMRCODBL)["CON" S GMRCSERV=$P(GMRCODBL,";") I $D(^GMR(123.5,GMRCSERV,0)) S GMRCSERV=$P(^GMR(123.5,GMRCSERV,0),U) Q
.I $G(GMRCODBL)["PRC" D
..S GMRCPROC=$P(GMRCODBL,";")
..I $D(^GMR(123.3,GMRCPROC)) D
...I $D(^GMR(123.3,GMRCPROC,2,1,0)) S GMRCSERV=^GMR(123.3,GMRCPROC,2,1,0) Q
Q GMRCSERV
;
OUTPUT ;add data to message array
I '$D(^XTMP("GMRCP85_ORDERS")) D Q
.S GMRCREP(3)="REPORT DATA NO LONGER AVAILABLE. A NEW SEARCH MUST BE COMPLETED."
.S GMRCREP(4)="SEE GMRC*3.0*85 PATCH DESCRIPTION FOR INSTRUCTIONS."
I $O(^XTMP("GMRCP85_ORDERS",0))="" D Q
.S GMRCREP(3)="No CONSULT or PROCEDURE orders found with the "
.S GMRCREP(4)="'Code not valid for Coding System' rejection message."
N GMRCINC,GMRCPAT,GMRCSERV,GMRCDATE,GMRCONBR,GMRCNAME,GMRCTEMP,LINECNT,TOTAL
S GMRCINC=0,GMRCPAT="",TOTAL=0
S GMRCREP(3)="PATIENT"
S GMRCREP(4)=" SERVICE"_$$REPEAT^XLFSTR(" ",44)_" ORDER DATE ORDER #"
S GMRCREP(5)=$$REPEAT^XLFSTR("-",78)
S LINECNT=6
F S GMRCPAT=$O(^XTMP("GMRCP85_ORDERS",GMRCPAT)) Q:$G(GMRCPAT)="" D
.Q:$G(GMRCPAT)=0
.S GMRCREP(LINECNT)=$G(GMRCPAT),LINECNT=LINECNT+1
.F S GMRCINC=$O(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC)) Q:+$G(GMRCINC)'>0 D
..S GMRCSERV=$P(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,2)
..S GMRCDATE=$P(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,3) S GMRCDATE=$$FMTE^XLFDT(GMRCDATE,"2DZ") ;MM/DD/YY
..S GMRCONBR=$P(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,4)
..S GMRCSERV=$E(GMRCSERV,0,53)
..I $L(GMRCSERV)<53 S GMRCSERV=GMRCSERV_$$REPEAT^XLFSTR(" ",(53-$L(GMRCSERV)))
..S GMRCREP(LINECNT)=" "_GMRCSERV_$J(GMRCDATE,10)_$J(GMRCONBR,14),LINECNT=LINECNT+1,TOTAL=TOTAL+1
.S GMRCREP(LINECNT)="",LINECNT=LINECNT+1
.S GMRCREP(LINECNT)=""
S GMRCREP(LINECNT)="TOTAL ORDERS FOUND: "_TOTAL
Q
;
MAIL(XMTEXT,XMSUB,XMY,SUBSCR) ;SEND AN EMAIL
;PARAMETERS: XMTEXT => STRING CONTAINING NAME OF ARRAY CONTAINING MESSAGE TEXT (REQUIRED)
; XMSUB => STRING CONTAINING THE SUBJECT OF THE MESSAGE (REQUIRED)
; XMY => REFERENCE TO AN ARRAY CONTAINING THE RECIPIENTS (OPTIONAL)
; SUBSCR => STRING CONTAINING THE SUBSCIPT WITHIN ^XTMP WHERE RECIPIENTS ARE STORED (OPTIONAL)
;RETURN: $$MAIL => STRING CONTAINING XMMG (ERROR STRING)^XMERR (NUMBER OF ERRORS)
N XMMG,XMDUZ,XMZ,XMERR,DIFROM,GMRCMSG
Q:'$D(XMTEXT)!($G(XMSUB)="")
I $D(XMY)=0 D
.I $G(SUBSCR)'="",($Q(^XTMP(SUBSCR,0))[SUBSCR) D Q
..K ^XTMP(SUBSCR,0)
..M XMY=^XTMP(SUBSCR)
..K ^XTMP(SUBSCR)
.I $D(ZTQUEUED)>0 D
..S XMY(DUZ)=""
.E D
..S GMRCMSG(1)=" "
..S GMRCMSG(2)="Select the recipient(s) of the report below."
..D MAILOUT(.GMRCMSG)
S XMDUZ="GMRC*3.0*85 Install@"_^XMB("NETNAME")
D ^XMD ;ICR #10070
K GMRCMSG
I $D(XMMG)>0 D
.S GMRCMSG(1)=" "
.S GMRCMSG(2)="Unable to email the report:"
.S GMRCMSG(3)=XMMG
.D MAILOUT(.GMRCMSG)
Q $G(XMMG)_U_$G(XMERR)
;
MAILOUT(MESSAGE) ;OUTPUT THE GMRCMSG ARRAY FROM MAIL LINE TAG
;IF KIDS IS NOT EXECUTING, OUTPUT THE MESSAGE TO THE SCREEN
I $G(XPDNM)="" D
.N LINE S LINE=0 F S LINE=$O(MESSAGE(LINE)) Q:+$G(LINE)=0 W MESSAGE(LINE),!
E D MES^XPDUTL(.MESSAGE)
Q
;
OUTPUT2 ;programmer mode write data to screen
I '$D(^XTMP("GMRCP85_ORDERS")) D Q
.W !,"REPORT DATA NO LONGER AVAILABLE. A NEW SEARCH MUST BE COMPLETED."
.W !,"SEE GMRC*3.0*85 PATCH DESCRIPTION FOR INSTRUCTIONS."
I $O(^XTMP("GMRCP85_ORDERS",0))="" D Q
.W !,"No CONSULT or PROCEDURE orders found with the "
.W !,"'Code not valid for Coding System' rejection message."
N GMRCINC,GMRCPAT,GMRCSERV,GMRCDATE,GMRCONBR,GMRCNAME,GMRCTEMP S GMRCINC=0,GMRCPAT=""
D HEADER
F S GMRCPAT=$O(^XTMP("GMRCP85_ORDERS",GMRCPAT)) Q:$G(GMRCPAT)="" D
.Q:$G(GMRCPAT)=0
.W !!,$G(GMRCPAT)
.F S GMRCINC=$O(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC)) Q:+$G(GMRCINC)'>0 D
..S GMRCSERV=$P(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,2)
..S GMRCDATE=$P(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,3) S GMRCDATE=$$FMTE^XLFDT(GMRCDATE,"2DZ") ;MM/DD/YY
..S GMRCONBR=$P(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,4)
..I $L(GMRCSERV)<53 S GMRCSERV=GMRCSERV_$$REPEAT^XLFSTR(" ",(53-$L(GMRCSERV)))
..W !," "_GMRCSERV_$J(GMRCDATE,10)_$J(GMRCONBR,14)
Q
;
W @IOF
W "PATIENT",!
W " SERVICE"_$$REPEAT^XLFSTR(" ",44)_" ORDER DATE ORDER #"
W !,$$REPEAT^XLFSTR("-",78)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCP85 9857 printed Dec 13, 2024@01:46:34 Page 2
GMRCP85 ;WAT - Post-install for GMRC*3.0*85 ;12/22/15 07:21
+1 ;;3.0;CONSULT/REQUEST TRACKING;**85**;DEC 27, 1997;Build 3
+2 ;;ICR 6257 - GMRC READ OF OR(100 GLOBAL
+3 ;;10061 VADPT (DEM and KVA)
+4 ;;10104 XLFSTR ;;10103 XLFDT ;;10141 XPDUTL ;;1131 ^XMB("NETNAME")
+5 ;;10063 ZTLOAD
+6 ;;3169 ^ORD(101.43 ;;873 ^ORD(100.98
+7 ;; ZT* TaskMan variables
+8 QUIT
RECIP ;RECIPIENTS
+1 if $DATA(^XTMP("GMRCP85RECIPS"))
KILL ^XTMP("GMRCP85RECIPS")
+2 WRITE !,$$CJ^XLFSTR("*** REJECTED CONSULT/PROCEDURE ORDERS REPORT ",80," "),!
+3 WRITE $$CJ^XLFSTR("DATE DEFAULT VALUE REPORT QUESTIONS ***",80," "),!
+4 WRITE !,"The post-install will create the REJECTED CONSULT/PROCEDURE ORDERS",!
+5 WRITE "REPORT, which contains orders rejected by Consults with the message:",!
+6 WRITE " Code not valid for Coding System",!!
+7 WRITE "The installer MUST include the site's local Clinical Application Coordinators",!
+8 WRITE "(CACs) or other identified points-of-contact as recipients of this report.",!!
+9 WRITE !!,"Please select the recipients for the REJECTED CONSULT/PROCEDURE ORDERS REPORT",!
+10 WRITE "below."
+11 NEW XMDUZ,XMDF,XMMG,X,XMOUT,XMY
+12 SET XMDUZ=DUZ
+13 ;ICR #10067
DO DES^XMA21
+14 IF $DATA(XMY)>9
Begin DoDot:1
+15 SET ^XTMP("GMRCP85RECIPS",0)=$$FMADD^XLFDT(DT,31)_U_DT_U_"RECIPIENTS OF REJECTED CONSULT/PROCEDURE ORDERS REPORT"
+16 MERGE ^XTMP("GMRCP85RECIPS")=XMY
End DoDot:1
+17 QUIT
PRE ; pre-init
+1 DO RECIP
+2 QUIT
POST ; post init
+1 NEW GMRCPOST
+2 SET GMRCPOST=1
+3 DO QUEUE("find rejected gmrc orders report","ORDSRCH^GMRCP85","FILE #100 SEARCH FOR ORDERS REJECTED BY GMRC")
+4 QUIT
+5 ;
RESTART ;index redux
+1 WRITE !,"Queueing file 100 search..."
+2 DO QUEUE("GMRC*3.0*85 file #100 search","ORDSRCH^GMRCP85","FILE #100 SEARCH FOR ORDERS REJECTED BY GMRC")
+3 QUIT
QUEUE(GMRCMSG,ZTRTN,ZTDESC) ;CREATE A SPECIFIED TASK
+1 ;PARAMETERS: GMRCMSG => STRING CONTAINING THE TEXT TO OUTPUT TO THE SCREEN
+2 ; ZTRTN => STRING CONTAINING THE ROUTINE TASKMAN SHOULD EXECUTE
+3 ; ZTDESC => STRING CONTAINING THE TASK'S DESCRIPTION
+4 NEW ZTDTH,ZTIO,ZTSK
+5 DO BMES^XPDUTL("Queueing "_GMRCMSG_"...")
+6 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,0,10)
+7 SET ZTIO=""
+8 DO ^%ZTLOAD
+9 IF +$GET(ZTSK)=0
Begin DoDot:1
+10 IF $GET(GMRCPOST)
DO BMES^XPDUTL("Unable to queue the "_GMRCMSG_"; file a Remedy ticket for assistance.")
+11 IF '$TEST
WRITE "ERROR",!,"Unable to queue the "_GMRCMSG_"; file a Remedy ticket for assistance.",!
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 IF $GET(GMRCPOST)
Begin DoDot:2
+14 DO BMES^XPDUTL("DONE - Task #"_ZTSK)
End DoDot:2
+15 IF '$TEST
WRITE "DONE",!,"Task #"_ZTSK,!
End DoDot:1
+16 QUIT
+17 ;
ORDSRCH ;find rejected consult/procedure orders
+1 KILL ^XTMP("GMRCP85_ORDERS")
+2 SET ^XTMP("GMRCP85_ORDERS",0)=$$FMADD^XLFDT(DT,31)_U_DT_U_"REJECTED ORDERS FOUND BY GMRC*3.0*85"
+3 NEW GMRCON,GMRCPROC,DISPGRP,GMRCIFN,DCTXT,COUNT,GMRCREP,GMRCSTAT,DFN,GMRCNAME,GMRCSVC,GMRCDATE,LOOPCNT
+4 SET COUNT=1
SET LOOPCNT=0
+5 SET GMRCON=""
SET GMRCON=$ORDER(^ORD(100.98,"B","CONSULTS",""))
+6 SET GMRCPROC=""
SET GMRCPROC=$ORDER(^ORD(100.98,"B","PROCEDURES",""))
+7 NEW STRTDATE
SET STRTDATE=3150901
+8 ;restart search from last date referenced
IF $DATA(^XTMP("GMRCP85","OR100AF","DATE"))
SET STRTDATE=^XTMP("GMRCP85","OR100AF","DATE")
+9 NEW GMRCIDX
SET GMRCIDX=$QUERY(^OR(100,"AF",STRTDATE))
+10 FOR
SET GMRCIDX=$QUERY(@GMRCIDX)
if GMRCIDX'?1"^OR(100,""AF"",".E!($GET(ZTSTOP)=1)
QUIT
Begin DoDot:1
+11 SET GMRCIFN=$PIECE(GMRCIDX,",",4)
if +$GET(GMRCIFN)'>0
QUIT
+12 ;DISPLAY GROUP
SET DISPGRP=$PIECE(^OR(100,GMRCIFN,0),U,11)
+13 if DISPGRP'=GMRCON&(DISPGRP'=GMRCPROC)
QUIT
+14 ;not rejected
if $DATA(^OR(100,GMRCIFN,6))=0
QUIT
+15 ;REJECTED
if $PIECE(^OR(100,GMRCIFN,6),U)'=7
QUIT
+16 ;DC REASON TEXT
SET DCTXT=$PIECE(^OR(100,GMRCIFN,6),U,5)
+17 if $GET(DCTXT)'["Code not valid for Coding System"
QUIT
+18 SET GMRCSVC=""
+19 IF $DATA(^OR(100,GMRCIFN,4.5,"ID","SERVICE"))
Begin DoDot:2
+20 SET GMRCSVC=$ORDER(^OR(100,GMRCIFN,4.5,"ID","SERVICE",0))
+21 SET GMRCSVC=^OR(100,GMRCIFN,4.5,GMRCSVC,1)
SET GMRCSVC=$PIECE(^GMR(123.5,GMRCSVC,0),U)
End DoDot:2
+22 IF $GET(GMRCSVC)=""
Begin DoDot:2
+23 SET GMRCSVC=$$FINDSVC(.GMRCIFN)
if +$GET(GMRCSVC)=""
SET GMRCSVC="NOT FOUND"
End DoDot:2
+24 SET GMRCNAME=$PIECE(^OR(100,GMRCIFN,0),U,2)
if $GET(GMRCNAME)'["DPT"
QUIT
+25 SET DFN=+$GET(GMRCNAME)
+26 ;get pt name and last 4
DO DEM^VADPT
+27 ;to service
SET GMRCDATE=$PIECE(^OR(100,GMRCIFN,0),U,7)
+28 ;name + last 4
SET ^XTMP("GMRCP85_ORDERS",VADM(1)_" ("_VA("BID")_")",COUNT)=VADM(1)_"("_VA("BID")_")"_U_GMRCSVC_U_GMRCDATE_U_GMRCIFN
SET COUNT=COUNT+1
+29 DO KVA^VADPT
+30 SET LOOPCNT=LOOPCNT+1
+31 IF LOOPCNT#500=0
IF ($$S^%ZTLOAD)
NEW X
SET ZTSTOP=1
SET X=$$S^%ZTLOAD("Received shutdown request")
End DoDot:1
+32 ;SEND STATUS EMAIL
+33 IF +$GET(ZTSTOP)=0
Begin DoDot:1
+34 SET GMRCREP(1)="The file #100 search process from GMRC*3.0*85 was successfully completed."
+35 SET GMRCREP(2)=""
+36 DO OUTPUT
End DoDot:1
+37 IF '$TEST
Begin DoDot:1
+38 KILL GMRCREP
+39 SET GMRCREP(1)="The file #100 search process from GMRC*3.0*85 has unexpectedly stopped."
+40 SET GMRCREP(2)="If you or the system manager did not stop the process, please check the"
+41 SET GMRCREP(3)="error log and file a Remedy ticket for assistance."
+42 SET GMRCREP(4)=""
+43 SET GMRCREP(5)="To requeue the cleanup/conversion process, run RESTART^GMRCP85 from the"
+44 SET GMRCREP(6)="programmer prompt."
End DoDot:1
+45 SET GMRCSTAT=$$MAIL("GMRCREP(","PATCH GMRC*3.0*85 ORDER SEARCH STATUS",,"GMRCP85RECIPS")
+46 IF +GMRCSTAT
IF ($GET(ZTSTOP)=1)
Begin DoDot:1
+47 SET ^XTMP("GMRCP85",0)=$$FMADD^XLFDT($$NOW^XLFDT,7,0,0,0)_U_$$NOW^XLFDT_U_"GMRC*3.0*85 POST-INSTALL DATA"
+48 ;capture last date referenced to restart search from.
SET ^XTMP("GMRCP85","OR100AF","DATE")=$PIECE(GMRCIDX,",",3)
End DoDot:1
+49 SET ZTREQ="@"
+50 QUIT
FINDSVC(GMRCIFN) ; service not directly accessbile in the OR(100 entry, go find it
+1 NEW GMRCSERV,GMRCODBL,GMRCPROC
SET GMRCSERV=""
+2 ;GMRSERV - CONSULT SERVICE
+3 ;GMRCODBL - ORDERABLE ITEM FROM OR(100
+4 IF $DATA(^OR(100,GMRCIFN,.1,1,0))
Begin DoDot:1
+5 SET GMRCODBL=^OR(100,GMRCIFN,.1,1,0)
End DoDot:1
+6 IF $DATA(^ORD(101.43,$GET(GMRCODBL),0))
Begin DoDot:1
+7 ; service IEN;99CON or procedure IEN;99PRC
SET GMRCODBL=$PIECE(^ORD(101.43,$GET(GMRCODBL),0),U,2)
+8 IF $GET(GMRCODBL)["CON"
SET GMRCSERV=$PIECE(GMRCODBL,";")
IF $DATA(^GMR(123.5,GMRCSERV,0))
SET GMRCSERV=$PIECE(^GMR(123.5,GMRCSERV,0),U)
QUIT
+9 IF $GET(GMRCODBL)["PRC"
Begin DoDot:2
+10 SET GMRCPROC=$PIECE(GMRCODBL,";")
+11 IF $DATA(^GMR(123.3,GMRCPROC))
Begin DoDot:3
+12 IF $DATA(^GMR(123.3,GMRCPROC,2,1,0))
SET GMRCSERV=^GMR(123.3,GMRCPROC,2,1,0)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT GMRCSERV
+14 ;
OUTPUT ;add data to message array
+1 IF '$DATA(^XTMP("GMRCP85_ORDERS"))
Begin DoDot:1
+2 SET GMRCREP(3)="REPORT DATA NO LONGER AVAILABLE. A NEW SEARCH MUST BE COMPLETED."
+3 SET GMRCREP(4)="SEE GMRC*3.0*85 PATCH DESCRIPTION FOR INSTRUCTIONS."
End DoDot:1
QUIT
+4 IF $ORDER(^XTMP("GMRCP85_ORDERS",0))=""
Begin DoDot:1
+5 SET GMRCREP(3)="No CONSULT or PROCEDURE orders found with the "
+6 SET GMRCREP(4)="'Code not valid for Coding System' rejection message."
End DoDot:1
QUIT
+7 NEW GMRCINC,GMRCPAT,GMRCSERV,GMRCDATE,GMRCONBR,GMRCNAME,GMRCTEMP,LINECNT,TOTAL
+8 SET GMRCINC=0
SET GMRCPAT=""
SET TOTAL=0
+9 SET GMRCREP(3)="PATIENT"
+10 SET GMRCREP(4)=" SERVICE"_$$REPEAT^XLFSTR(" ",44)_" ORDER DATE ORDER #"
+11 SET GMRCREP(5)=$$REPEAT^XLFSTR("-",78)
+12 SET LINECNT=6
+13 FOR
SET GMRCPAT=$ORDER(^XTMP("GMRCP85_ORDERS",GMRCPAT))
if $GET(GMRCPAT)=""
QUIT
Begin DoDot:1
+14 if $GET(GMRCPAT)=0
QUIT
+15 SET GMRCREP(LINECNT)=$GET(GMRCPAT)
SET LINECNT=LINECNT+1
+16 FOR
SET GMRCINC=$ORDER(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC))
if +$GET(GMRCINC)'>0
QUIT
Begin DoDot:2
+17 SET GMRCSERV=$PIECE(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,2)
+18 ;MM/DD/YY
SET GMRCDATE=$PIECE(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,3)
SET GMRCDATE=$$FMTE^XLFDT(GMRCDATE,"2DZ")
+19 SET GMRCONBR=$PIECE(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,4)
+20 SET GMRCSERV=$EXTRACT(GMRCSERV,0,53)
+21 IF $LENGTH(GMRCSERV)<53
SET GMRCSERV=GMRCSERV_$$REPEAT^XLFSTR(" ",(53-$LENGTH(GMRCSERV)))
+22 SET GMRCREP(LINECNT)=" "_GMRCSERV_$JUSTIFY(GMRCDATE,10)_$JUSTIFY(GMRCONBR,14)
SET LINECNT=LINECNT+1
SET TOTAL=TOTAL+1
End DoDot:2
+23 SET GMRCREP(LINECNT)=""
SET LINECNT=LINECNT+1
+24 SET GMRCREP(LINECNT)=""
End DoDot:1
+25 SET GMRCREP(LINECNT)="TOTAL ORDERS FOUND: "_TOTAL
+26 QUIT
+27 ;
MAIL(XMTEXT,XMSUB,XMY,SUBSCR) ;SEND AN EMAIL
+1 ;PARAMETERS: XMTEXT => STRING CONTAINING NAME OF ARRAY CONTAINING MESSAGE TEXT (REQUIRED)
+2 ; XMSUB => STRING CONTAINING THE SUBJECT OF THE MESSAGE (REQUIRED)
+3 ; XMY => REFERENCE TO AN ARRAY CONTAINING THE RECIPIENTS (OPTIONAL)
+4 ; SUBSCR => STRING CONTAINING THE SUBSCIPT WITHIN ^XTMP WHERE RECIPIENTS ARE STORED (OPTIONAL)
+5 ;RETURN: $$MAIL => STRING CONTAINING XMMG (ERROR STRING)^XMERR (NUMBER OF ERRORS)
+6 NEW XMMG,XMDUZ,XMZ,XMERR,DIFROM,GMRCMSG
+7 if '$DATA(XMTEXT)!($GET(XMSUB)="")
QUIT
+8 IF $DATA(XMY)=0
Begin DoDot:1
+9 IF $GET(SUBSCR)'=""
IF ($QUERY(^XTMP(SUBSCR,0))[SUBSCR)
Begin DoDot:2
+10 KILL ^XTMP(SUBSCR,0)
+11 MERGE XMY=^XTMP(SUBSCR)
+12 KILL ^XTMP(SUBSCR)
End DoDot:2
QUIT
+13 IF $DATA(ZTQUEUED)>0
Begin DoDot:2
+14 SET XMY(DUZ)=""
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 SET GMRCMSG(1)=" "
+17 SET GMRCMSG(2)="Select the recipient(s) of the report below."
+18 DO MAILOUT(.GMRCMSG)
End DoDot:2
End DoDot:1
+19 SET XMDUZ="GMRC*3.0*85 Install@"_^XMB("NETNAME")
+20 ;ICR #10070
DO ^XMD
+21 KILL GMRCMSG
+22 IF $DATA(XMMG)>0
Begin DoDot:1
+23 SET GMRCMSG(1)=" "
+24 SET GMRCMSG(2)="Unable to email the report:"
+25 SET GMRCMSG(3)=XMMG
+26 DO MAILOUT(.GMRCMSG)
End DoDot:1
+27 QUIT $GET(XMMG)_U_$GET(XMERR)
+28 ;
MAILOUT(MESSAGE) ;OUTPUT THE GMRCMSG ARRAY FROM MAIL LINE TAG
+1 ;IF KIDS IS NOT EXECUTING, OUTPUT THE MESSAGE TO THE SCREEN
+2 IF $GET(XPDNM)=""
Begin DoDot:1
+3 NEW LINE
SET LINE=0
FOR
SET LINE=$ORDER(MESSAGE(LINE))
if +$GET(LINE)=0
QUIT
WRITE MESSAGE(LINE),!
End DoDot:1
+4 IF '$TEST
DO MES^XPDUTL(.MESSAGE)
+5 QUIT
+6 ;
OUTPUT2 ;programmer mode write data to screen
+1 IF '$DATA(^XTMP("GMRCP85_ORDERS"))
Begin DoDot:1
+2 WRITE !,"REPORT DATA NO LONGER AVAILABLE. A NEW SEARCH MUST BE COMPLETED."
+3 WRITE !,"SEE GMRC*3.0*85 PATCH DESCRIPTION FOR INSTRUCTIONS."
End DoDot:1
QUIT
+4 IF $ORDER(^XTMP("GMRCP85_ORDERS",0))=""
Begin DoDot:1
+5 WRITE !,"No CONSULT or PROCEDURE orders found with the "
+6 WRITE !,"'Code not valid for Coding System' rejection message."
End DoDot:1
QUIT
+7 NEW GMRCINC,GMRCPAT,GMRCSERV,GMRCDATE,GMRCONBR,GMRCNAME,GMRCTEMP
SET GMRCINC=0
SET GMRCPAT=""
+8 DO HEADER
+9 FOR
SET GMRCPAT=$ORDER(^XTMP("GMRCP85_ORDERS",GMRCPAT))
if $GET(GMRCPAT)=""
QUIT
Begin DoDot:1
+10 if $GET(GMRCPAT)=0
QUIT
+11 WRITE !!,$GET(GMRCPAT)
+12 FOR
SET GMRCINC=$ORDER(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC))
if +$GET(GMRCINC)'>0
QUIT
Begin DoDot:2
+13 SET GMRCSERV=$PIECE(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,2)
+14 ;MM/DD/YY
SET GMRCDATE=$PIECE(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,3)
SET GMRCDATE=$$FMTE^XLFDT(GMRCDATE,"2DZ")
+15 SET GMRCONBR=$PIECE(^XTMP("GMRCP85_ORDERS",GMRCPAT,GMRCINC),U,4)
+16 IF $LENGTH(GMRCSERV)<53
SET GMRCSERV=GMRCSERV_$$REPEAT^XLFSTR(" ",(53-$LENGTH(GMRCSERV)))
+17 WRITE !," "_GMRCSERV_$JUSTIFY(GMRCDATE,10)_$JUSTIFY(GMRCONBR,14)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+1 WRITE @IOF
+2 WRITE "PATIENT",!
+3 WRITE " SERVICE"_$$REPEAT^XLFSTR(" ",44)_" ORDER DATE ORDER #"
+4 WRITE !,$$REPEAT^XLFSTR("-",78)
+5 QUIT
