BLRDOCRM.m

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")