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
Q
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 !
Q
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
Q
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)
Q
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)
Q
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)
Q
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)
Q
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."
Q
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
Q
WH ;Retrieves pregnancy and lactation status for patient
K GMRPWH
S GMRPWH=$$POSTSHRT^WVRPCOR(+GMRPDFN)
Q
--- 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
