BLRDOCRM ; IHS/MSC/MKK - Patient Reminder Document ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**1041**;NOV 1, 1997;Build 23
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
;
EP ; EP
PEP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
;
D ADDTMENU^BLRGMENU("FUTURE^BLRDOCRM","Future/Current Orders")
D ADDTMENU^BLRGMENU("ALLORDS^BLRDOCRM","All Orders")
;
D MENUDRVR^BLRGMENU("RPMS Lab","Patient Reminder Document")
Q
;
FUTURE ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
;
Q:$$FUTUREI("Patient Reminder Document")="Q"
;
F S LRODT=$O(^LRO(69,"D",LRDFN,LRODT),-1) Q:LRODT<TODAY!(QFLG="Q") D
. S LRSP="A"
. F S LRSP=$O(^LRO(69,"D",LRDFN,LRODT,LRSP),-1) Q:LRSP<1!(QFLG="Q") D PATLINE
;
I ORDCNT W !!,?9,ORDCNT," Order",$$PLURAL^BLRUTIL7(ORDCNT),"."
E D
. F I=3:1:5 K HEADER(I)
. D HEADERDT^BLRGMENU
. W ?9,"No Future/Current Orders for Patient found."
;
D ^%ZISC
D PRESSKEY^BLRGMENU
Q
;
FUTUREI(HDR1) ; EP - Initialization
S HEADER(1)=HDR1
D HEADERDT^BLRGMENU
D ^XBFMK
S DIR(0)="PO^9000001:EMZ"
D ^DIR
I +$G(DIRUT) Q $$BADSTUFQ("No/Quit/Invalid input.")
;
S DFN=+Y,PATNAME=$$GET1^DIQ(2,DFN,.01)
S HEADER(2)=PATNAME_" ["_DFN_"] HRCN:"_$$GET1^DIQ(9000001.41,DUZ(2)_","_DFN,.02)
;
D ^%ZIS
I POP Q $$BADSTUFQ("I/O Issue.")
;
U IO
S HEADER(3)=" "
S $E(HEADER(4),10)=$$COLHEAD^BLRGMENU("Estimated",19)
S HEADER(5)="Order #"
S $E(HEADER(5),10)="Date/Time Collect"
S $E(HEADER(5),31)="Test Description"
S $E(HEADER(5),55)="Urgency"
S $E(HEADER(5),64)="Ordering Provider"
;
S ORDCNT=0
S MAXLINES=IOSL-4,LINES=MAXLINES+10
S PG=0,(QFLG,HDRONE)="NO"
;
S LRDFN=$$GET1^DIQ(2,DFN,"LABORATORY REFERENCE","I")
S LRODT="A",TODAY=$$DT^XLFDT
Q "OK"
;
PATLINE ; EP - Line of Data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q"
;
D PATDATAB
;
W ORDNUM
W ?9,ESTCPRNT
S LROT=0
F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1!(QFLG="Q") D
. I LINES>MAXLINES D Q:QFLG="Q"
.. D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
.. Q:QFLG="Q"
.. W ORDNUM
.. W ?9,ESTCPRNT
. ;
. S LROTIEN=LROT_","_ORDIEN
. S F60DESC=$$GET1^DIQ(69.03,LROTIEN,.01)
. S URGENCY=$$GET1^DIQ(69.03,LROTIEN,1)
. ;
. W ?30,$E(F60DESC,1,22)
. W ?54,$E(URGENCY,1,7)
. W ?63,$E(PROVIDER,1,17)
. W !
. S LINES=LINES+1
Q
;
PATDATAB ; EP - Breakout Data
S ORDCNT=ORDCNT+1
S ORDIEN=LRSP_","_LRODT
S ORDNUM=$$GET1^DIQ(69.01,ORDIEN,9.5,"I")
S ORDERDT=$$GET1^DIQ(69.01,ORDIEN,5,"I")
S PROVIDER=$$GET1^DIQ(69.01,ORDIEN,7)
S ESTCOLDT=$$GET1^DIQ(69.01,ORDIEN,5.5,"I") ; EST. DATE/TIME OF COLLECTION
S ESTCPRNT=$$UP^XLFSTR($$FMTE^XLFDT(ESTCOLDT,"5MPZ")) ; EST. DATE/TIME OF COLLECTION Print String
S ESTCPRNT=$P(ESTCPRNT," ")_$J($P(ESTCPRNT," ",2,3),9)
Q
;
;
ALLORDS ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
;
Q:$$FUTUREI("Patient Orders Document")="Q"
;
F S LRODT=$O(^LRO(69,"D",LRDFN,LRODT),-1) Q:LRODT<1!(QFLG="Q") D
. S LRSP="A"
. F S LRSP=$O(^LRO(69,"D",LRDFN,LRODT,LRSP),-1) Q:LRSP<1!(QFLG="Q") D PATLINE
;
W !!,?9,ORDCNT," Order",$$PLURAL(ORDCNT),"."
D ^%ZISC
D PRESSKEY^BLRGMENU
Q
;
;
; ============================= UTILITIES =============================
;
JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q
;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
K BLRVERN,BLRVERN2
;
S BLRVERN=$P($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=$G(TWO)
Q
;
BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
S TAB=$S($L($G(TAB))<1:4,1:TAB)
W !!,?TAB,STR," Routine Ends."
D PRESSKEY^BLRGMENU(TAB+5)
Q
;
BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "Q"uit
D BADSTUFF(STR,$G(TAB))
Q "Q"
;
PLURAL(CNT) ; EP - If CNT'=1, return S else return ""
Q $S(CNT=1:"",1:"s")
;
PLURALI(CNT) ; EP - If CNT'=1, return IES else return Y
Q $S(CNT=1:"y",1:"ies")
BLRDOCRM ; IHS/MSC/MKK - Patient Reminder Document ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**1041**;NOV 1, 1997;Build 23
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ;
EP ; EP
PEP ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 ;
+5 DO ADDTMENU^BLRGMENU("FUTURE^BLRDOCRM","Future/Current Orders")
+6 DO ADDTMENU^BLRGMENU("ALLORDS^BLRDOCRM","All Orders")
+7 ;
+8 DO MENUDRVR^BLRGMENU("RPMS Lab","Patient Reminder Document")
+9 QUIT
+10 ;
FUTURE ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 ;
+5 IF $$FUTUREI("Patient Reminder Document")="Q"
QUIT
+6 ;
+7 FOR
SET LRODT=$ORDER(^LRO(69,"D",LRDFN,LRODT),-1)
IF LRODT<TODAY!(QFLG="Q")
QUIT
Begin DoDot:1
+8 SET LRSP="A"
+9 FOR
SET LRSP=$ORDER(^LRO(69,"D",LRDFN,LRODT,LRSP),-1)
IF LRSP<1!(QFLG="Q")
QUIT
DO PATLINE
End DoDot:1
+10 ;
+11 IF ORDCNT
WRITE !!,?9,ORDCNT," Order",$$PLURAL^BLRUTIL7(ORDCNT),"."
+12 IF '$TEST
Begin DoDot:1
+13 FOR I=3:1:5
KILL HEADER(I)
+14 DO HEADERDT^BLRGMENU
+15 WRITE ?9,"No Future/Current Orders for Patient found."
End DoDot:1
+16 ;
+17 DO ^%ZISC
+18 DO PRESSKEY^BLRGMENU
+19 QUIT
+20 ;
FUTUREI(HDR1) ; EP - Initialization
+1 SET HEADER(1)=HDR1
+2 DO HEADERDT^BLRGMENU
+3 DO ^XBFMK
+4 SET DIR(0)="PO^9000001:EMZ"
+5 DO ^DIR
+6 IF +$GET(DIRUT)
QUIT $$BADSTUFQ("No/Quit/Invalid input.")
+7 ;
+8 SET DFN=+Y
SET PATNAME=$$GET1^DIQ(2,DFN,.01)
+9 SET HEADER(2)=PATNAME_" ["_DFN_"] HRCN:"_$$GET1^DIQ(9000001.41,DUZ(2)_","_DFN,.02)
+10 ;
+11 DO ^%ZIS
+12 IF POP
QUIT $$BADSTUFQ("I/O Issue.")
+13 ;
+14 USE IO
+15 SET HEADER(3)=" "
+16 SET $EXTRACT(HEADER(4),10)=$$COLHEAD^BLRGMENU("Estimated",19)
+17 SET HEADER(5)="Order #"
+18 SET $EXTRACT(HEADER(5),10)="Date/Time Collect"
+19 SET $EXTRACT(HEADER(5),31)="Test Description"
+20 SET $EXTRACT(HEADER(5),55)="Urgency"
+21 SET $EXTRACT(HEADER(5),64)="Ordering Provider"
+22 ;
+23 SET ORDCNT=0
+24 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
+25 SET PG=0
SET (QFLG,HDRONE)="NO"
+26 ;
+27 SET LRDFN=$$GET1^DIQ(2,DFN,"LABORATORY REFERENCE","I")
+28 SET LRODT="A"
SET TODAY=$$DT^XLFDT
+29 QUIT "OK"
+30 ;
PATLINE ; EP - Line of Data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+2 ;
+3 DO PATDATAB
+4 ;
+5 WRITE ORDNUM
+6 WRITE ?9,ESTCPRNT
+7 SET LROT=0
+8 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LROT))
IF LROT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+9 IF LINES>MAXLINES
Begin DoDot:2
+10 DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
+11 IF QFLG="Q"
QUIT
+12 WRITE ORDNUM
+13 WRITE ?9,ESTCPRNT
End DoDot:2
IF QFLG="Q"
QUIT
+14 ;
+15 SET LROTIEN=LROT_","_ORDIEN
+16 SET F60DESC=$$GET1^DIQ(69.03,LROTIEN,.01)
+17 SET URGENCY=$$GET1^DIQ(69.03,LROTIEN,1)
+18 ;
+19 WRITE ?30,$EXTRACT(F60DESC,1,22)
+20 WRITE ?54,$EXTRACT(URGENCY,1,7)
+21 WRITE ?63,$EXTRACT(PROVIDER,1,17)
+22 WRITE !
+23 SET LINES=LINES+1
End DoDot:1
+24 QUIT
+25 ;
PATDATAB ; EP - Breakout Data
+1 SET ORDCNT=ORDCNT+1
+2 SET ORDIEN=LRSP_","_LRODT
+3 SET ORDNUM=$$GET1^DIQ(69.01,ORDIEN,9.5,"I")
+4 SET ORDERDT=$$GET1^DIQ(69.01,ORDIEN,5,"I")
+5 SET PROVIDER=$$GET1^DIQ(69.01,ORDIEN,7)
+6 ; EST. DATE/TIME OF COLLECTION
SET ESTCOLDT=$$GET1^DIQ(69.01,ORDIEN,5.5,"I")
+7 ; EST. DATE/TIME OF COLLECTION Print String
SET ESTCPRNT=$$UP^XLFSTR($$FMTE^XLFDT(ESTCOLDT,"5MPZ"))
+8 SET ESTCPRNT=$PIECE(ESTCPRNT," ")_$JUSTIFY($PIECE(ESTCPRNT," ",2,3),9)
+9 QUIT
+10 ;
+11 ;
ALLORDS ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 ;
+5 IF $$FUTUREI("Patient Orders Document")="Q"
QUIT
+6 ;
+7 FOR
SET LRODT=$ORDER(^LRO(69,"D",LRDFN,LRODT),-1)
IF LRODT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+8 SET LRSP="A"
+9 FOR
SET LRSP=$ORDER(^LRO(69,"D",LRDFN,LRODT,LRSP),-1)
IF LRSP<1!(QFLG="Q")
QUIT
DO PATLINE
End DoDot:1
+10 ;
+11 WRITE !!,?9,ORDCNT," Order",$$PLURAL(ORDCNT),"."
+12 DO ^%ZISC
+13 DO PRESSKEY^BLRGMENU
+14 QUIT
+15 ;
+16 ;
+17 ; ============================= UTILITIES =============================
+18 ;
JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 QUIT
+4 ;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
+1 KILL BLRVERN,BLRVERN2
+2 ;
+3 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+4 IF $LENGTH($GET(TWO))
SET BLRVERN2=$GET(TWO)
+5 QUIT
+6 ;
BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
+1 SET TAB=$SELECT($LENGTH($GET(TAB))<1:4,1:TAB)
+2 WRITE !!,?TAB,STR," Routine Ends."
+3 DO PRESSKEY^BLRGMENU(TAB+5)
+4 QUIT
+5 ;
BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "Q"uit
+1 DO BADSTUFF(STR,$GET(TAB))
+2 QUIT "Q"
+3 ;
PLURAL(CNT) ; EP - If CNT'=1, return S else return ""
+1 QUIT $SELECT(CNT=1:"",1:"s")
+2 ;
PLURALI(CNT) ; EP - If CNT'=1, return IES else return Y
+1 QUIT $SELECT(CNT=1:"y",1:"ies")
