Routine: GMRPNCW

GMRPNCW ;SLC/DJP,MKB,MJC - CWAD Utility ;Jan 13, 2021@10:55

 ;;1.0;TEXT INTEGRATION UTILITIES;**120,341**;Jun 20, 1997;Build 23

EN ;Entry for secondary option to lookup patient, display warnings

 Q:IOST?1"P".E  D SETUP("REVIEW PATIENT WARNINGS")

 N X,Y,DTOUT,DUOUT,DIRUT,DIROUT

 S GMRPEN=1,GMRPOPT=1

 F  D  Q:$D(GMRPQT)

 .W ! S DIC="^DPT(",DIC(0)="AEQM" D ^DIC

 .S:(Y<1)!($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) GMRPQT=1

 K GMRPQT,GMRPEN,GMRPOPT,GMRPDFN,DIC,VAROOT

SETUP(TITLE)    ;entry utilities, option header

 N GMRPI K GMRPQT,GMRPSTOP,GMRPLIST,GMRPOPT,GMRPAT

 W @IOF,!!?(IOM-$L(TITLE)\2),TITLE,! F GMRPI=1:1:IOM W "-"

W !

ENPAT ;Additional entry point; must be passed Patient DFN in Y.

 ;Setting GMRPEN permits individual options to turn on the Clin Alerts.

 ;When ON, the keys GMRPC and/or GMRPWA may be required in the future.

 Q:'$D(GMRPEN)

 Q:+Y<1  N DIC,DFN,GMRPTYP

 S (GMRPDFN,DFN)=+Y,$P(GMRPDFN,U,2)=$P(^DPT(+GMRPDFN,0),U)

 D ALLERGY,WH

 I '$D(^TIU(8925,"ADCPT",+GMRPDFN)),'$D(GMRPALG),$S($D(GMRPOPT):1,$D(GMRPHOLD):1,1:0),'$D(GMRPWH) D  Q

 . W !!,"No Patient Warnings on file for "

 . W $P(GMRPDFN,U,2),".",!

 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause

 D CWLKP I $D(GMRPOPT),'$D(GMRPQT) D PRINT

END K GMRPQT,GMRPCWA,GMRPALG,GMRPX,X,CWA,GMRPWH

CWLKP ;Lookup and presentation of CWA indicators

 S GMRPCWA=""

 F CWA("DOCTYPE")=30,31,27 D

 . I $D(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),7))!$D(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),8)) S GMRPTYP=$S(CWA("DOCTYPE")=30:"C",CWA("DOCTYPE")=31:"W",1:"D") D LIST ;GMRP*2.5*50 include amended as well as complete

 I $D(GMRPALG) S GMRPCWA=GMRPCWA_"A" W !?24,"A: Known allergies"

 S GMRPCWA=GMRPCWA_$G(GMRPWH)

 I $G(GMRPWH)["P" W !,?24,"P: Pregnant"

 I $G(GMRPWH)["L" W !,?24,"L: Lactating"

 I '$L(GMRPCWA) S GMRPQT=1 Q

 I '$D(GMRPOPT),$D(GMRPHOLD) W ! N DIR,X,Y S DIR(0)="E" D ^DIR W:$D(DIRUT)!(Y=1) ! Q

 D RESPOND:$D(GMRPOPT)

LIST ;List data lines -- expects GMRPTYP="C" or "W" or "A" or "D"

 N GMRPDT,GMRPIFN,GMRPDDT,CTR,COUNT,STATUS

 S GMRPCWA=GMRPCWA_GMRPTYP

 ; GMRP*2.5*50 include amended as well as complete:

 S GMRPDT(7)=$O(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),7,0))

 S GMRPDT(8)=$O(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),8,0))

 ; Get inverse date & status of most recent complete or amended note:

 I 'GMRPDT(7) S GMRPDT=+GMRPDT(8) Q:'GMRPDT  S STATUS=8

 I '$G(GMRPDT) I 'GMRPDT(8) S GMRPDT=+GMRPDT(7) Q:'GMRPDT  S STATUS=7

 I '$G(GMRPDT) D

 . I GMRPDT(7)<GMRPDT(8) S GMRPDT=GMRPDT(7),STATUS=7 Q

 . S GMRPDT=GMRPDT(8),STATUS=8

 S GMRPDDT=$$DATE^TIULS((9999999-GMRPDT),"MM/DD/YY HR:MIN")

 S (CTR,COUNT)=0

 F  S COUNT=$O(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),7,COUNT)) Q:+COUNT'>0  S CTR=CTR+1 ;Counts the number of COMPLETE warnings on file

 S COUNT=0

 F  S COUNT=$O(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),8,COUNT)) Q:+COUNT'>0  S CTR=CTR+1 ; GMRP*2.5*50, adds the number of amended warnings on file

 W !?11," (",CTR," note",$S(CTR>1:"s",1:" "),")",?24,GMRPTYP,": ",GMRPDDT

 W $$ADDEND(STATUS)

ADDEND(STATUS) ; If addended or amended, return most recent of these, for most recent note.

 N IEN,AMENDDT,ADDMDT,ADDMIEN,AAMENDDT,MAX,MSG

 ; GMRP*2.5*50, get most recent complete OR AMENDED note:

 S IEN=0

 S IEN=$O(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),STATUS,GMRPDT,IEN))

 S AMENDDT=+$G(^TIU(8925,IEN,16)) ;date of note amendment

 S ADDMIEN=+$O(^TIU(8925,"DAD",IEN,""),-1) ; IEN of most recent addendum

 I +$P($G(^TIU(8925,ADDMIEN,0)),U,5)<7 S ADDMIEN=0 ;forget addm if not signed

 S ADDMDT=+$G(^TIU(8925,ADDMIEN,12)) ; date of addm

 S AAMENDDT=+$G(^TIU(8925,ADDMIEN,16)) ;date of addm amendment

 I AAMENDDT>AMENDDT S AMENDDT=AAMENDDT

 S MAX=$S(AMENDDT>ADDMDT:AMENDDT,1:ADDMDT)

 I MAX=0 S MSG="" G ADDX

 I MAX=AMENDDT S MSG="  (amended "_$$DATE^TIULS(AMENDDT,"MM/DD/YY HR:MIN")_")" G ADDX

 S MSG="  (addendum "_$$DATE^TIULS(ADDMDT,"MM/DD/YY HR:MIN")_")"

ADDX Q MSG

RESPOND ;prompt for warnings to display

 W !!,"Select patient warning(s) to display: "_GMRPCWA_"//"

 R GMRPX:60 I '$T!(GMRPX["^") S GMRPQT=1 Q

 S:GMRPX="" GMRPX=GMRPCWA

 I GMRPX["?" D QUES K GMRPX G RESPOND

 S GMRPX=$$UP^XLFSTR(GMRPX)

PRINT ;Prints Crisis Notes, Clin Warnings & Allergies using HS utilities.

 S X="GMTS" X ^%ZOSF("TEST") I '$T W $C(7) D  Q

 .W !,"This display uses the Health Summary, currently unavailable.",!

 N GMTSTITL,GMTSPRM,GMRPHSTYPE S GMTSTITL="PATIENT WARNINGS",GMTSPRM=""

 S:GMRPX["C" GMTSPRM="CN"

 I $L($T(CD^GMTSCW)) D

 .S:GMRPX["W" GMTSPRM=GMTSPRM_",CW"

 .S:GMRPX["D" GMTSPRM=GMTSPRM_",CD"

 I '$L($T(CD^GMTSCW)) D

 .S:GMRPX["W"!(GMRPX["D") GMTSPRM=GMTSPRM_",CW"

 S:GMRPX["A" GMTSPRM=GMTSPRM_",ADR"

 I GMTSPRM="" S GMRPQT=1

 I GMTSPRM'="" D

 .I $E(GMTSPRM)="," S GMTSPRM=$P(GMTSPRM,",",2,5)

 .D ENCWA^GMTS

 I GMRPX["P",GMRPX["L" S GMRPHSTYPE="VA-WH PREG & LAC STATUS"

 E  D

 .I GMRPX["P" S GMRPHSTYPE="VA-WH PREGNANCY STATUS"

 .I GMRPX["L" S GMRPHSTYPE="VA-WH LACTATION STATUS"

 I $G(GMRPHSTYPE)'="" D

 .K GMRPQT,^TMP("DIERR",$J)

 .S GMRPHSTYPE("NAME")=GMRPHSTYPE,GMRPHSTYPE=$$FIND1^DIC(142,,"X",GMRPHSTYPE)

 .I +GMRPHSTYPE=0 D  Q

 ..W !!,"Could not find the "_GMRPHSTYPE("NAME")_" health summary type."

 ..I $D(^TMP("DIERR",$J)) W ! D MSG^DIALOG() K ^TMP("DIERR",$J)

 ..S GMRPQT=1

 .D ENX^GMTSDVR(DFN,GMRPHSTYPE)

QUES ;Response to "?" at CWA prompt

 W !!,"     Enter:"

 W !?8,"C     for Crisis Notes",!?8,"W     for Clinical Warnings"

 W !?8,"A     for Allergies",!?8,"D     for Directive Notes"

 W !?8,"P     for Pregnant",!,?8,"L     for Lactating"

 W !?8,"CWADPL  for all 6 patient warnings"

 W !!?8,"or any combination of C, W, A, D, P and L without commas."

ALLERGY ;checks for allergies on file for patient - requires GMRPDFN

 ;Returns GMRPALG if allergies found ('$D if none)

 K GMRPALG,GMRA

 S X="GMRADPT" X ^%ZOSF("TEST") I $T D  Q

 .D EN1^GMRADPT S:+$G(GMRAL) GMRPALG=1 K GMRAL

 I $D(^DPT(+GMRPDFN,"PA",0)),$P(^(0),U,4)>0 S GMRPALG=1

WH ;Retrieves pregnancy and lactation status for patient

 K GMRPWH

 S GMRPWH=$$POSTSHRT^WVRPCOR(+GMRPDFN)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRPNCW   6107     printed  Mar 13, 2025@21:43:08                                                                                                                                                                                                     Page 2

GMRPNCW   ;SLC/DJP,MKB,MJC - CWAD Utility ;Jan 13, 2021@10:55

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**120,341**;Jun 20, 1997;Build 23

EN        ;Entry for secondary option to lookup patient, display warnings

 +1        if IOST?1"P".E

               QUIT

           DO SETUP("REVIEW PATIENT WARNINGS")

 +2        NEW X,Y,DTOUT,DUOUT,DIRUT,DIROUT

 +3        SET GMRPEN=1

           SET GMRPOPT=1

 +4        FOR

               Begin DoDot:1

 +5                WRITE !

                   SET DIC="^DPT("

                   SET DIC(0)="AEQM"

                   DO ^DIC

 +6                if (Y<1)!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))

                       SET GMRPQT=1

               End DoDot:1

               if $DATA(GMRPQT)

                   QUIT

 +7        KILL GMRPQT,GMRPEN,GMRPOPT,GMRPDFN,DIC,VAROOT

 +8        QUIT

SETUP(TITLE) ;entry utilities, option header

 +1        NEW GMRPI

           KILL GMRPQT,GMRPSTOP,GMRPLIST,GMRPOPT,GMRPAT

 +2        WRITE @IOF,!!?(IOM-$LENGTH(TITLE)\2),TITLE,!

           FOR GMRPI=1:1:IOM

               WRITE "-"

 +3        WRITE !

 +4        QUIT

ENPAT     ;Additional entry point; must be passed Patient DFN in Y.

 +1       ;Setting GMRPEN permits individual options to turn on the Clin Alerts.

 +2       ;When ON, the keys GMRPC and/or GMRPWA may be required in the future.

 +3        if '$DATA(GMRPEN)

               QUIT

 +4        if +Y<1

               QUIT

           NEW DIC,DFN,GMRPTYP

 +5        SET (GMRPDFN,DFN)=+Y

           SET $PIECE(GMRPDFN,U,2)=$PIECE(^DPT(+GMRPDFN,0),U)

 +6        DO ALLERGY

           DO WH

 +7        IF '$DATA(^TIU(8925,"ADCPT",+GMRPDFN))

               IF '$DATA(GMRPALG)

                   IF $SELECT($DATA(GMRPOPT):1,$DATA(GMRPHOLD):1,1:0)

                       IF '$DATA(GMRPWH)

                           Begin DoDot:1

 +8                            WRITE !!,"No Patient Warnings on file for "

 +9                            WRITE $PIECE(GMRPDFN,U,2),".",!

 +10      ; pause

                               IF $$READ^TIUU("EA","Press RETURN to continue...")

                           End DoDot:1

                           QUIT

 +11       DO CWLKP

           IF $DATA(GMRPOPT)

               IF '$DATA(GMRPQT)

                   DO PRINT

END        KILL GMRPQT,GMRPCWA,GMRPALG,GMRPX,X,CWA,GMRPWH

 +1        QUIT

CWLKP     ;Lookup and presentation of CWA indicators

 +1        SET GMRPCWA=""

 +2        FOR CWA("DOCTYPE")=30,31,27

               Begin DoDot:1

 +3       ;GMRP*2.5*50 include amended as well as complete

                   IF $DATA(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),7))!$DATA(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),8))

                       SET GMRPTYP=$SELECT(CWA("DOCTYPE")=30:"C",CWA("DOCTYPE")=31:"W",1:"D")

                       DO LIST

               End DoDot:1

 +4        IF $DATA(GMRPALG)

               SET GMRPCWA=GMRPCWA_"A"

               WRITE !?24,"A: Known allergies"

 +5        SET GMRPCWA=GMRPCWA_$GET(GMRPWH)

 +6        IF $GET(GMRPWH)["P"

               WRITE !,?24,"P: Pregnant"

 +7        IF $GET(GMRPWH)["L"

               WRITE !,?24,"L: Lactating"

 +8        IF '$LENGTH(GMRPCWA)

               SET GMRPQT=1

               QUIT

 +9        IF '$DATA(GMRPOPT)

               IF $DATA(GMRPHOLD)

                   WRITE !

                   NEW DIR,X,Y

                   SET DIR(0)="E"

                   DO ^DIR

                   if $DATA(DIRUT)!(Y=1)

                       WRITE !

                   QUIT

 +10       if $DATA(GMRPOPT)

               DO RESPOND

 +11       QUIT

LIST      ;List data lines -- expects GMRPTYP="C" or "W" or "A" or "D"

 +1        NEW GMRPDT,GMRPIFN,GMRPDDT,CTR,COUNT,STATUS

 +2        SET GMRPCWA=GMRPCWA_GMRPTYP

 +3       ; GMRP*2.5*50 include amended as well as complete:

 +4        SET GMRPDT(7)=$ORDER(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),7,0))

 +5        SET GMRPDT(8)=$ORDER(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),8,0))

 +6       ; Get inverse date & status of most recent complete or amended note:

 +7        IF 'GMRPDT(7)

               SET GMRPDT=+GMRPDT(8)

               if 'GMRPDT

                   QUIT

               SET STATUS=8

 +8        IF '$GET(GMRPDT)

               IF 'GMRPDT(8)

                   SET GMRPDT=+GMRPDT(7)

                   if 'GMRPDT

                       QUIT

                   SET STATUS=7

 +9        IF '$GET(GMRPDT)

               Begin DoDot:1

 +10               IF GMRPDT(7)<GMRPDT(8)

                       SET GMRPDT=GMRPDT(7)

                       SET STATUS=7

                       QUIT

 +11               SET GMRPDT=GMRPDT(8)

                   SET STATUS=8

               End DoDot:1

 +12       SET GMRPDDT=$$DATE^TIULS((9999999-GMRPDT),"MM/DD/YY HR:MIN")

 +13       SET (CTR,COUNT)=0

 +14      ;Counts the number of COMPLETE warnings on file

FOR

               SET COUNT=$ORDER(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),7,COUNT))

               if +COUNT'>0

                   QUIT

               SET CTR=CTR+1

 +15       SET COUNT=0

 +16      ; GMRP*2.5*50, adds the number of amended warnings on file

FOR

               SET COUNT=$ORDER(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),8,COUNT))

               if +COUNT'>0

                   QUIT

               SET CTR=CTR+1

 +17       WRITE !?11," (",CTR," note",$SELECT(CTR>1:"s",1:" "),")",?24,GMRPTYP,": ",GMRPDDT

 +18       WRITE $$ADDEND(STATUS)

 +19       QUIT

ADDEND(STATUS) ; If addended or amended, return most recent of these, for most recent note.

 +1        NEW IEN,AMENDDT,ADDMDT,ADDMIEN,AAMENDDT,MAX,MSG

 +2       ; GMRP*2.5*50, get most recent complete OR AMENDED note:

 +3        SET IEN=0

 +4        SET IEN=$ORDER(^TIU(8925,"ADCPT",+GMRPDFN,CWA("DOCTYPE"),STATUS,GMRPDT,IEN))

 +5       ;date of note amendment

           SET AMENDDT=+$GET(^TIU(8925,IEN,16))

 +6       ; IEN of most recent addendum

           SET ADDMIEN=+$ORDER(^TIU(8925,"DAD",IEN,""),-1)

 +7       ;forget addm if not signed

           IF +$PIECE($GET(^TIU(8925,ADDMIEN,0)),U,5)<7

               SET ADDMIEN=0

 +8       ; date of addm

           SET ADDMDT=+$GET(^TIU(8925,ADDMIEN,12))

 +9       ;date of addm amendment

           SET AAMENDDT=+$GET(^TIU(8925,ADDMIEN,16))

 +10       IF AAMENDDT>AMENDDT

               SET AMENDDT=AAMENDDT

 +11       SET MAX=$SELECT(AMENDDT>ADDMDT:AMENDDT,1:ADDMDT)

 +12       IF MAX=0

               SET MSG=""

               GOTO ADDX

 +13       IF MAX=AMENDDT

               SET MSG="  (amended "_$$DATE^TIULS(AMENDDT,"MM/DD/YY HR:MIN")_")"

               GOTO ADDX

 +14       SET MSG="  (addendum "_$$DATE^TIULS(ADDMDT,"MM/DD/YY HR:MIN")_")"

ADDX       QUIT MSG

 +1       ;

RESPOND   ;prompt for warnings to display

 +1        WRITE !!,"Select patient warning(s) to display: "_GMRPCWA_"//"

 +2        READ GMRPX:60

           IF '$TEST!(GMRPX["^")

               SET GMRPQT=1

               QUIT

 +3        if GMRPX=""

               SET GMRPX=GMRPCWA

 +4        IF GMRPX["?"

               DO QUES

               KILL GMRPX

               GOTO RESPOND

 +5        SET GMRPX=$$UP^XLFSTR(GMRPX)

 +6        QUIT

PRINT     ;Prints Crisis Notes, Clin Warnings & Allergies using HS utilities.

 +1        SET X="GMTS"

           XECUTE ^%ZOSF("TEST")

           IF '$TEST

               WRITE $CHAR(7)

               Begin DoDot:1

 +2                WRITE !,"This display uses the Health Summary, currently unavailable.",!

               End DoDot:1

               QUIT

 +3        NEW GMTSTITL,GMTSPRM,GMRPHSTYPE

           SET GMTSTITL="PATIENT WARNINGS"

           SET GMTSPRM=""

 +4        if GMRPX["C"

               SET GMTSPRM="CN"

 +5        IF $LENGTH($TEXT(CD^GMTSCW))

               Begin DoDot:1

 +6                if GMRPX["W"

                       SET GMTSPRM=GMTSPRM_",CW"

 +7                if GMRPX["D"

                       SET GMTSPRM=GMTSPRM_",CD"

               End DoDot:1

 +8        IF '$LENGTH($TEXT(CD^GMTSCW))

               Begin DoDot:1

 +9                if GMRPX["W"!(GMRPX["D")

                       SET GMTSPRM=GMTSPRM_",CW"

               End DoDot:1

 +10       if GMRPX["A"

               SET GMTSPRM=GMTSPRM_",ADR"

 +11       IF GMTSPRM=""

               SET GMRPQT=1

 +12       IF GMTSPRM'=""

               Begin DoDot:1

 +13               IF $EXTRACT(GMTSPRM)=","

                       SET GMTSPRM=$PIECE(GMTSPRM,",",2,5)

 +14               DO ENCWA^GMTS

               End DoDot:1

 +15       IF GMRPX["P"

               IF GMRPX["L"

                   SET GMRPHSTYPE="VA-WH PREG & LAC STATUS"

 +16      IF '$TEST

               Begin DoDot:1

 +17               IF GMRPX["P"

                       SET GMRPHSTYPE="VA-WH PREGNANCY STATUS"

 +18               IF GMRPX["L"

                       SET GMRPHSTYPE="VA-WH LACTATION STATUS"

               End DoDot:1

 +19       IF $GET(GMRPHSTYPE)'=""

               Begin DoDot:1

 +20               KILL GMRPQT,^TMP("DIERR",$JOB)

 +21               SET GMRPHSTYPE("NAME")=GMRPHSTYPE

                   SET GMRPHSTYPE=$$FIND1^DIC(142,,"X",GMRPHSTYPE)

 +22               IF +GMRPHSTYPE=0

                       Begin DoDot:2

 +23                       WRITE !!,"Could not find the "_GMRPHSTYPE("NAME")_" health summary type."

 +24                       IF $DATA(^TMP("DIERR",$JOB))

                               WRITE !

                               DO MSG^DIALOG()

                               KILL ^TMP("DIERR",$JOB)

 +25                       SET GMRPQT=1

                       End DoDot:2

                       QUIT

 +26               DO ENX^GMTSDVR(DFN,GMRPHSTYPE)

               End DoDot:1

 +27       QUIT

QUES      ;Response to "?" at CWA prompt

 +1        WRITE !!,"     Enter:"

 +2        WRITE !?8,"C     for Crisis Notes",!?8,"W     for Clinical Warnings"

 +3        WRITE !?8,"A     for Allergies",!?8,"D     for Directive Notes"

 +4        WRITE !?8,"P     for Pregnant",!,?8,"L     for Lactating"

 +5        WRITE !?8,"CWADPL  for all 6 patient warnings"

 +6        WRITE !!?8,"or any combination of C, W, A, D, P and L without commas."

 +7        QUIT

ALLERGY   ;checks for allergies on file for patient - requires GMRPDFN

 +1       ;Returns GMRPALG if allergies found ('$D if none)

 +2        KILL GMRPALG,GMRA

 +3        SET X="GMRADPT"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               Begin DoDot:1

 +4                DO EN1^GMRADPT

                   if +$GET(GMRAL)

                       SET GMRPALG=1

                   KILL GMRAL

               End DoDot:1

               QUIT

 +5        IF $DATA(^DPT(+GMRPDFN,"PA",0))

               IF $PIECE(^(0),U,4)>0

                   SET GMRPALG=1

 +6        QUIT

WH        ;Retrieves pregnancy and lactation status for patient

 +1        KILL GMRPWH

 +2        SET GMRPWH=$$POSTSHRT^WVRPCOR(+GMRPDFN)

 +3        QUIT

GMRPNCW.m