PXRMNTFY ;SLC/PKR - Routines for notifications. ;Jan 13, 2023@19:04
;;2.0;CLINICAL REMINDERS;**24,45,71,84**;Feb 04, 2005;Build 2
;
;SAC EXEMPTION 20030908-01 : Use proper variable scoping instead of
; namespace variable scoping
;
;Reference to EN^ORB3 in ICR #1362
;Reference to GETRECIPS^WVRPCPT1 in ICR #6200
;Reference to $$SAVESRND^WVRPCPT1 in ICR #6336
;Reference to $$GETNOTID^ORBSMART in ICR #6341
;Reference to $$CODEC^ICDEX and $$CODECS^ICDEX in ICR #5747
;Reference to ^AUPNPROB( in ICR #3837
;Reference to ^AUPNVSIT( in ICR #2028
;
;========================
DELOPEN(DFN,ORN) ;Delete open OE/RR Notifications.
N ALIST,IND,ORID,XQAID
D PATIENT^XQALERT("ALIST",DFN)
F IND=1:1:ALIST D
. S XQAID=$P(ALIST(IND),U,2)
. S ORID=$P(XQAID,";",1)
. I $P(ORID,",",3)=ORN D DELETE^XQALERT
Q
;
;========================
SUICIDE(EVENT,DFN,VISIT) ;Send an alert if the patient attempted or
;completed suicide, as marked by a health factor. This is called
;from DATACHGR^PXRMPINF which is invoked by the protocol PXK VISIT
;DATA EVENT.
N DATE,HFAIEN,HFBIEN,HFSAIEN,HFSCIEN,MSG,VHFIEN
S HFSAIEN=$$FIND1^DIC(9999999.64,"","","MH SUICIDE ATTEMPTED")
S HFSCIEN=$$FIND1^DIC(9999999.64,"","","MH SUICIDE COMPLETED")
S (MSG,VHFIEN)=""
F S VHFIEN=$O(^XTMP(EVENT,VISIT,"HF",VHFIEN)) Q:VHFIEN="" D
. S HFAIEN=$P($G(^XTMP(EVENT,VISIT,"HF",VHFIEN,0,"AFTER")),U,1)
. S HFBIEN=$P($G(^XTMP(EVENT,VISIT,"HF",VHFIEN,0,"BEFORE")),U,1)
.;If after is null then the health factor has been deleted so delete
.;any open alerts.
. I HFAIEN="",HFBIEN'="" D DELOPEN^PXRMNTFY(DFN,77) Q
.;If the before and after are the same the HF is not new so do not
.;send the alert.
. I HFAIEN=HFBIEN Q
. I HFAIEN=HFSAIEN S MSG="Suicide attempted"
. I HFAIEN=HFSCIEN S MSG="Suicide completed"
I MSG="" Q
S DATE=$P(^AUPNVSIT(VISIT,0),U,1)
;If DATE is more than 30 days in the past do not send the alert.
I $$FMDIFF^XLFDT(DT,DATE)>30 Q
S MSG=MSG_" on "_$$FMTE^XLFDT(DATE,"5Z")
D EN^ORB3(77,DFN,"","",MSG,"")
Q
;
;========================
TALERT(DFN,PROV,ATYPE,MUC) ;Send pregnancy/lactation status change alert
;MUC - 1 => MEDICALLY UNABLE TO CONCEIVE AND LAB TEST
; 2 => MEDICALLY UNABLE TO CONCEIVE AND ICD CODE
; 0 OR UNDEFINED => MEDICALLY ABLE TO CONCEIVE
S ATYPE=+$G(ATYPE),MUC=+$G(MUC)
N ORNOTNM,ORNOTIEN,MESSAGE
S ORNOTNM=$S(ATYPE=1:"PREGNANCY STATUS REVIEW",ATYPE=2:"LACTATION STATUS REVIEW",1:"")
S ORNOTIEN=$$GETNOTID^ORBSMART(ORNOTNM) Q:ORNOTIEN<1
I ATYPE=1 D
.I MUC=1 S MESSAGE="R/O ectopic preg if Hx sterilization-POS preg test & Dx unable to conceive"
.I MUC=2 S MESSAGE="Dx unable to conceive-ICD codes entered c/w preg-review/correct record"
I $G(MESSAGE)="" S MESSAGE="Possible "_$S(ATYPE=1:"pregnancy",ATYPE=2:"lactation",1:"")_" status conflict: confirm, consider status update."
D EN^ORB3(ORNOTIEN,DFN,"",.PROV,MESSAGE)
Q
;
WH(EVENT,DFN,VISIT,GMPLIFN) ;Determine whether to send pregnancy/lactation status change
;based on ICD/SNOMED CT code.
N CODELIST,EXIT,PROVARR,PXRMSDT,SEND,SENDMSG,STATUS,MESSAGES,TAX,TAXIEN,WHDATA
N CACHE,CODE,ACODE
I $G(EVENT)'="" D Q:$G(EXIT)
.I $G(VISIT)'="" D Q:$G(EXIT)
..I '$D(^XTMP(EVENT,VISIT,"POV")) S EXIT=1 Q
..D WHICD(.CODELIST,.PROVARR,EVENT,VISIT)
.I $G(VISIT)="" D Q:$G(EXIT)
..I '(($D(^XTMP(EVENT,"DISCHARGE")))!($D(^XTMP(EVENT,"MOVEMENT")))!($D(^XTMP(EVENT,"SERVICE")))!($D(^XTMP(EVENT,"SERVICE46")))) S EXIT=1 Q
..D WHPTF(.CODELIST,.PROVARR,DFN)
I (($G(EVENT)="")!($G(VISIT)=""))&($G(GMPLIFN)>0) D Q:$G(EXIT)
.I '$D(^AUPNPROB(GMPLIFN)) S EXIT=1 Q
.D WHPBL(.CODELIST,.PROVARR,GMPLIFN)
I '$D(CODELIST) Q
;
S SENDMSG=0,STATUS=1
F TAX="VA-WH CURRENTLY PREGNANT","VA-WH RECENTLY PREGNANT","VA-WH POSSIBLE PREGNANCY","VA-WH CURRENTLY LACTATING" D Q:STATUS'=1
.S TAXIEN=$O(^PXD(811.2,"B",TAX,0)) Q:'+TAXIEN
.S CODESYS=""
.F S CODESYS=$O(CODELIST(CODESYS)) Q:(CODESYS="")!(STATUS'=1) D
..I '$D(^PXD(811.2,TAXIEN,20,"AE",CODESYS)) Q
..S CODE=""
..F S CODE=$O(CODELIST(CODESYS,CODE)) Q:(CODE="")!(STATUS'=1) D
...I $D(^PXD(811.2,TAXIEN,20,"AE",CODESYS,CODE)) D
....S STATUS=$$WHAPPL(DFN,$P($P(CODELIST(CODESYS,CODE),U,1),"|",1))
....I STATUS'=1 Q
....S SENDMSG=SENDMSG+1
....S SENDMSG(SENDMSG)=TAX_U_CODESYS_"|"_CODE_"|"_CODELIST(CODESYS,CODE)
I (SENDMSG=0)!(STATUS'=1) Q
F CODE=1:1:SENDMSG Q:$G(CACHE)=-1 D
.S SEND=0
.I SENDMSG(CODE)["PREGNAN" D
..I '$D(CACHE("PREGNANCY")) D
...S PXRMSDT=$P($P(SENDMSG(CODE),"|",3),U,1)
...D WHEVAL(.CACHE,"VA-WH UPDATE PREGNANCY STATUS",.PXRMSDT)
..Q:CACHE=-1
..I ((SENDMSG(CODE)["CURRENTLY")!(SENDMSG(CODE)["POSSIBLE"))&((CACHE("PREGNANCY","STATE")'="PREGNANT")!((CACHE("PREGNANCY","STATE")="PREGNANT")&(CACHE("PREGNANCY","OUT DATED")))) D Q
...S SEND=1,ACODE=$P($P(SENDMSG(CODE),U,2),"|",2) Q:ACODE=""
...I $D(SEND("ACODES1",SEND,ACODE)) Q
...S SEND("ACODES1",SEND,ACODE)="",SEND("ACODES2",SEND,CODE)=""
..I (SENDMSG(CODE)["RECENTLY")&((CACHE("PREGNANCY","STATE")="PREGNANT")&(CACHE("PREGNANCY","OUT DATED")=0)) D
...S SEND=1,ACODE=$P($P(SENDMSG(CODE),U,2),"|",2) Q:ACODE=""
...I $D(SEND("ACODES1",SEND,ACODE)) Q
...S SEND("ACODES1",SEND,ACODE)="",SEND("ACODES2",SEND,CODE)=""
.I SENDMSG(CODE)["LACTATING" D
..I '$D(CACHE("LACTATION")) D
...S PXRMSDT=$P($P(SENDMSG(CODE),"|",3),U,1)
...D WHEVAL(.CACHE,"VA-WH UPDATE LACTATION STATUS",.PXRMSDT)
..Q:CACHE=-1
..I CACHE("LACTATION","STATE")'="LACTATING" D
...S SEND=2,ACODE=$P($P(SENDMSG(CODE),U,2),"|",2) Q:ACODE=""
...I $D(SEND("ACODES1",SEND,ACODE)) Q
...S SEND("ACODES1",SEND,ACODE)="",SEND("ACODES2",SEND,CODE)=""
.I $D(SEND("ACODES2",SEND,CODE)) D
..I '$D(MESSAGES(SEND,"PXRMPROV")) D
...N PXRMPROV
...D GETRECIPS^WVRPCPT1(.PXRMPROV,DFN,"CODE",$S(SEND=1:"P",SEND=2:"L",1:""),0,$P(SENDMSG(CODE),U,3))
...I +$G(PXRMPROV(0))=-1 D
....S ERROR(1,0)="Error retrieving Women's Health managers: "_$P(PXRMPROV(0),U,2)
....D ERROR(.ERROR)
....K PXRMPROV
....M PXRMPROV=PROVARR
...I $O(PXRMPROV(""))'="" M MESSAGES(SEND,"PXRMPROV")=PXRMPROV
..I $D(MESSAGES(SEND,"PXRMPROV")) D
...S WHDATA("ID")=DFN_U_$S(SEND=1:"P",SEND=2:"L",1:"")
...S WHDATA("CODE")=$P(SENDMSG(CODE),U,2)
...S STATUS=$$SAVESRND^WVRPCPT1(.WHDATA)
...I +STATUS=-1 S ERROR(1,0)="Error saving status conflict notification data: "_$P(STATUS,U,2) D ERROR(.ERROR)
...I +STATUS<1 K MESSAGES(SEND)
S SEND=0 F S SEND=$O(MESSAGES(SEND)) Q:'+SEND D
.N PXRMPROV
.M PXRMPROV=MESSAGES(SEND,"PXRMPROV")
.D TALERT(DFN,.PXRMPROV,SEND,$S((SEND=1)&($G(CACHE("PREGNANCY","MUC"))):2,1:0))
Q
;
ERROR(ERROR) ;Send an email that an error occurred
N CNT,DATA,INDEX,SOURCE
S CNT=$O(ERROR("?"),-1)+1,ERROR(CNT,0)=""
S CNT=CNT+1,ERROR(CNT,0)="The contents of the XTMP global that triggered this error:"
F SOURCE="^XTMP(EVENT)","WHDATA" D
.I $D(@SOURCE) D ACOPY^PXRMUTIL(SOURCE,"DATA()")
.S INDEX=0 F S INDEX=$O(DATA(INDEX)) Q:'+INDEX S CNT=CNT+1,ERROR(CNT,0)=DATA(INDEX)
.K DATA
I $G(PTYPE)'="" S CNT=CNT+1,ERROR(CNT,0)="PTYPE="_PTYPE
K ^TMP("PXRMXMZ",$J)
M ^TMP("PXRMXMZ",$J)=ERROR
D SEND^PXRMMSG("PXRMXMZ","Clinical Reminder Code Listener")
K ^TMP("PXRMXMZ",$J)
Q
WHAPPL(DFN,PXRMSDT) ;Determine if code is applicable for the given date
; $$WHAPPL: -1 => error
; 0 => not applicable
; 1 => applicable
N NAME,RIEN,NODE,RNAME,DEFARR,FIEV,STATUS
K ^TMP("PXRHM",$J)
S NAME="VA-WH POTENTIALLY UNSAFE MEDICATIONS REPORT - COHORT"
S RIEN=$O(^PXD(811.9,"B",NAME,"")) I RIEN'>0 Q -1
S NODE=$G(^PXD(811.9,RIEN,0))
S RNAME=$S($P(NODE,U,3)'="":$P(NODE,U,3),1:$P(NODE,U))
D DEF^PXRMLDR(RIEN,.DEFARR)
D EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,.PXRMSDT)
S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U)
K ^TMP("PXRHM",$J)
I (STATUS="CNBD")!(STATUS="ERROR") Q -1
I $$STATMTCH^PXRMORCH(STATUS,"N") Q 0
Q 1
WHEVAL(CACHE,NAME,PXRMSDT) ;Evaluate pregancy or lactation reminder
N RIEN,STATUS,SUB,FIND,DOC,DATE,EDD
K ^TMP("PXRHM",$J)
S RIEN=$O(^PXD(811.9,"B",NAME,"")) Q:RIEN<0
S NODE=$G(^PXD(811.9,RIEN,0)) Q:NODE=""
S RNAME=$S($P(NODE,U,3)'="":$P(NODE,U,3),1:$P(NODE,U)) Q:RNAME=""
D MAINDF^PXRM(DFN,RIEN,1,PXRMSDT)
S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U)
I (STATUS="CNBD")!(STATUS="ERROR") S CACHE=-1 Q
S SUB=$P($P(NAME,"VA-WH UPDATE ",2)," ") I SUB="" S CACHE=-1 Q
S FIND=$S(SUB="PREGNANCY":3,SUB="LACTATION":2,1:"") I FIND="" S CACHE=-1 Q
S CACHE(SUB,"STATE")=$G(^TMP("PXRHM",$J,RIEN,"FIEVAL",FIND,1,SUB_" STATE"))
S DOC=$G(^TMP("PXRHM",$J,RIEN,"FIEVAL",FIND,1,"DOCUMENTATION STATUS"))
S DATE=$G(^TMP("PXRHM",$J,RIEN,"FIEVAL",FIND,1,"DATE"))
S CACHE(SUB,"OUT DATED")=0
I DOC'="NO DOCUMENTATION",$$STATMTCH^PXRMORCH(STATUS,"D") D
.I SUB="PREGNANCY" D
..I DOC="INCOMPLETE" D
...I CACHE(SUB,"STATE")="PREGNANT" D
....S EDD=$G(^TMP("PXRHM",$J,RIEN,"FIEVAL",FIND,1,"EDD"))
....I EDD="" S EDD=$$NEWDATE^PXRMDATE($G(^TMP("PXRHM",$J,RIEN,"FIEVAL",FIND,1,"LAST MENSTRUAL PERIOD DATE")),"+","40W")
....I EDD<DT S CACHE(SUB,"OUT DATED")=1
...I CACHE(SUB,"STATE")'="PREGNANT",DATE<$$NEWDATE^PXRMDATE(DT,"-","1Y") S CACHE(SUB,"OUT DATED")=1
..I DOC="COMPLETE" S CACHE(SUB,"OUT DATED")=1
.I SUB="LACTATION" S CACHE(SUB,"OUT DATED")=1
I SUB="PREGNANCY" S CACHE(SUB,"MUC")=$G(^TMP("PXRHM",$J,RIEN,"FIEVAL",1))
K ^TMP("PXRHM",$J)
S CACHE=1
Q
;
WHICD(CODELIST,PROVARR,EVENT,VISIT) ;Retrieve data from ^XTMP
N POVIEN,AFTER,BEFORE,CODEIEN,CODE,CODESYS,PRVIEN,PROVIEN,CDATE,ODATE
N DIVISION
S CDATE=$P($G(^XTMP(EVENT,VISIT,"VST",VISIT,0,"AFTER")),U),POVIEN=""
S ODATE=$P($G(^XTMP(EVENT,VISIT,"VST",VISIT,0,"AFTER")),U,13)
S DIVISION=$P($G(^XTMP(EVENT,VISIT,"VST",VISIT,0,"AFTER")),U,6)
F S POVIEN=$O(^XTMP(EVENT,VISIT,"POV",POVIEN)) Q:POVIEN="" D
.S AFTER=$G(^XTMP(EVENT,VISIT,"POV",POVIEN,0,"AFTER"))
.S BEFORE=$G(^XTMP(EVENT,VISIT,"POV",POVIEN,0,"BEFORE"))
.I (AFTER=BEFORE)!(AFTER="") Q
.S CODEIEN=$P(AFTER,U,1)
.D ADDICD(.CODELIST,CODEIEN,CDATE,ODATE,DIVISION)
S PRVIEN=0
F S PRVIEN=$O(^XTMP(EVENT,VISIT,"PRV",PRVIEN)) Q:PRVIEN'>0 D
.S AFTER=$G(^XTMP(EVENT,VISIT,"PRV",PRVIEN,0,"AFTER"))
.S PROVIEN=+$P(AFTER,U,1) I PROVIEN>0 S PROVARR(PROVIEN)=""
Q
;
WHPBL(CODELIST,PROVARR,GMPLIFN) ;Retrieve data from ^AUPNPROB
N NODE1,PIECE,PROVIEN,CODEIEN,CDATE,ODATE,DIVISION
I $P($G(^AUPNPROB(GMPLIFN,1)),U,2)="H" Q
S CDATE=$P($G(^AUPNPROB(GMPLIFN,802)),U)
S ODATE=$P($G(^AUPNPROB(GMPLIFN,0)),U,3)
S CODE=$P($G(^AUPNPROB(GMPLIFN,800)),U)
S DIVISION=$P($G(^AUPNPROB(GMPLIFN,0)),U,6)
I CODE'="" S CODELIST("SCT",CODE)=CDATE_$S(ODATE'="":"|"_ODATE,1:"")_$S(DIVISION'="":U_DIVISION,1:"")
S CODEIEN=$P($G(^AUPNPROB(GMPLIFN,0)),U)
D ADDICD(.CODELIST,CODEIEN,CDATE,ODATE,DIVISION)
S NODE1=$G(^AUPNPROB(GMPLIFN,1))
F PIECE=3:1:5 S PROVIEN=+$P(NODE1,U,PIECE) I PROVIEN>0 S PROVARR(PROVIEN)=""
Q
;
WHPTF(CODELIST,PROVARR,DFN) ;Retrieve data from ^XTMP
N TYPE,FIELD,VAIN,VAERR,DATE,BEFORE,AFTER
S DATE=$G(^XTMP(EVENT,"INTEREST DATE")),TYPE=""
F S TYPE=$O(^XTMP(EVENT,TYPE)) Q:TYPE="" S FIELD="" F S FIELD=$O(^XTMP(EVENT,TYPE,FIELD)) Q:FIELD="" D
.Q:FIELD="IENS"
.S AFTER=$G(^XTMP(EVENT,TYPE,FIELD,"NEW"))
.S BEFORE=$G(^XTMP(EVENT,TYPE,FIELD,"OLD"))
.I (AFTER=BEFORE)!(AFTER="") Q
.D ADDICD(.CODELIST,AFTER,DATE,$G(^XTMP(EVENT,"OCCURRED DATE")),$G(^XTMP(EVENT,"INSTITUTION")))
Q:'$D(CODELIST)
I $G(^XTMP(EVENT,"PRIMARY PROVIDER"))>0 S PROVARR(^XTMP(EVENT,"PRIMARY PROVIDER"))=""
I $G(^XTMP(EVENT,"ATTENDING PHYSICIAN"))>0 S PROVARR(^XTMP(EVENT,"ATTENDING PHYSICIAN"))=""
Q
ADDICD(CODELIST,CODEIEN,CODEDATE,OCCURDATE,DIVISION) ;Add ICD code to the CODELIST array
N CODE,CODESYS
S CODE=$$CODEC^ICDEX(80,CODEIEN)
I $P(CODE,U,1)=-1 Q
S CODESYS=$P($$CODECS^ICDEX(CODE,80,CODEDATE),U)
S CODESYS=$S(CODESYS=1:"ICD",CODESYS=30:"10D",1:"")
I CODESYS="" Q
S CODELIST(CODESYS,CODE)=CODEDATE_$S($G(OCCURDATE)'="":"|"_OCCURDATE,1:"")_$S($G(DIVISION)'="":U_DIVISION,1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMNTFY 12020 printed Apr 09, 2024@20:48:04 Page 2
PXRMNTFY ;SLC/PKR - Routines for notifications. ;Jan 13, 2023@19:04
+1 ;;2.0;CLINICAL REMINDERS;**24,45,71,84**;Feb 04, 2005;Build 2
+2 ;
+3 ;SAC EXEMPTION 20030908-01 : Use proper variable scoping instead of
+4 ; namespace variable scoping
+5 ;
+6 ;Reference to EN^ORB3 in ICR #1362
+7 ;Reference to GETRECIPS^WVRPCPT1 in ICR #6200
+8 ;Reference to $$SAVESRND^WVRPCPT1 in ICR #6336
+9 ;Reference to $$GETNOTID^ORBSMART in ICR #6341
+10 ;Reference to $$CODEC^ICDEX and $$CODECS^ICDEX in ICR #5747
+11 ;Reference to ^AUPNPROB( in ICR #3837
+12 ;Reference to ^AUPNVSIT( in ICR #2028
+13 ;
+14 ;========================
DELOPEN(DFN,ORN) ;Delete open OE/RR Notifications.
+1 NEW ALIST,IND,ORID,XQAID
+2 DO PATIENT^XQALERT("ALIST",DFN)
+3 FOR IND=1:1:ALIST
Begin DoDot:1
+4 SET XQAID=$PIECE(ALIST(IND),U,2)
+5 SET ORID=$PIECE(XQAID,";",1)
+6 IF $PIECE(ORID,",",3)=ORN
DO DELETE^XQALERT
End DoDot:1
+7 QUIT
+8 ;
+9 ;========================
SUICIDE(EVENT,DFN,VISIT) ;Send an alert if the patient attempted or
+1 ;completed suicide, as marked by a health factor. This is called
+2 ;from DATACHGR^PXRMPINF which is invoked by the protocol PXK VISIT
+3 ;DATA EVENT.
+4 NEW DATE,HFAIEN,HFBIEN,HFSAIEN,HFSCIEN,MSG,VHFIEN
+5 SET HFSAIEN=$$FIND1^DIC(9999999.64,"","","MH SUICIDE ATTEMPTED")
+6 SET HFSCIEN=$$FIND1^DIC(9999999.64,"","","MH SUICIDE COMPLETED")
+7 SET (MSG,VHFIEN)=""
+8 FOR
SET VHFIEN=$ORDER(^XTMP(EVENT,VISIT,"HF",VHFIEN))
if VHFIEN=""
QUIT
Begin DoDot:1
+9 SET HFAIEN=$PIECE($GET(^XTMP(EVENT,VISIT,"HF",VHFIEN,0,"AFTER")),U,1)
+10 SET HFBIEN=$PIECE($GET(^XTMP(EVENT,VISIT,"HF",VHFIEN,0,"BEFORE")),U,1)
+11 ;If after is null then the health factor has been deleted so delete
+12 ;any open alerts.
+13 IF HFAIEN=""
IF HFBIEN'=""
DO DELOPEN^PXRMNTFY(DFN,77)
QUIT
+14 ;If the before and after are the same the HF is not new so do not
+15 ;send the alert.
+16 IF HFAIEN=HFBIEN
QUIT
+17 IF HFAIEN=HFSAIEN
SET MSG="Suicide attempted"
+18 IF HFAIEN=HFSCIEN
SET MSG="Suicide completed"
End DoDot:1
+19 IF MSG=""
QUIT
+20 SET DATE=$PIECE(^AUPNVSIT(VISIT,0),U,1)
+21 ;If DATE is more than 30 days in the past do not send the alert.
+22 IF $$FMDIFF^XLFDT(DT,DATE)>30
QUIT
+23 SET MSG=MSG_" on "_$$FMTE^XLFDT(DATE,"5Z")
+24 DO EN^ORB3(77,DFN,"","",MSG,"")
+25 QUIT
+26 ;
+27 ;========================
TALERT(DFN,PROV,ATYPE,MUC) ;Send pregnancy/lactation status change alert
+1 ;MUC - 1 => MEDICALLY UNABLE TO CONCEIVE AND LAB TEST
+2 ; 2 => MEDICALLY UNABLE TO CONCEIVE AND ICD CODE
+3 ; 0 OR UNDEFINED => MEDICALLY ABLE TO CONCEIVE
+4 SET ATYPE=+$GET(ATYPE)
SET MUC=+$GET(MUC)
+5 NEW ORNOTNM,ORNOTIEN,MESSAGE
+6 SET ORNOTNM=$SELECT(ATYPE=1:"PREGNANCY STATUS REVIEW",ATYPE=2:"LACTATION STATUS REVIEW",1:"")
+7 SET ORNOTIEN=$$GETNOTID^ORBSMART(ORNOTNM)
if ORNOTIEN<1
QUIT
+8 IF ATYPE=1
Begin DoDot:1
+9 IF MUC=1
SET MESSAGE="R/O ectopic preg if Hx sterilization-POS preg test & Dx unable to conceive"
+10 IF MUC=2
SET MESSAGE="Dx unable to conceive-ICD codes entered c/w preg-review/correct record"
End DoDot:1
+11 IF $GET(MESSAGE)=""
SET MESSAGE="Possible "_$SELECT(ATYPE=1:"pregnancy",ATYPE=2:"lactation",1:"")_" status conflict: confirm, consider status update."
+12 DO EN^ORB3(ORNOTIEN,DFN,"",.PROV,MESSAGE)
+13 QUIT
+14 ;
WH(EVENT,DFN,VISIT,GMPLIFN) ;Determine whether to send pregnancy/lactation status change
+1 ;based on ICD/SNOMED CT code.
+2 NEW CODELIST,EXIT,PROVARR,PXRMSDT,SEND,SENDMSG,STATUS,MESSAGES,TAX,TAXIEN,WHDATA
+3 NEW CACHE,CODE,ACODE
+4 IF $GET(EVENT)'=""
Begin DoDot:1
+5 IF $GET(VISIT)'=""
Begin DoDot:2
+6 IF '$DATA(^XTMP(EVENT,VISIT,"POV"))
SET EXIT=1
QUIT
+7 DO WHICD(.CODELIST,.PROVARR,EVENT,VISIT)
End DoDot:2
if $GET(EXIT)
QUIT
+8 IF $GET(VISIT)=""
Begin DoDot:2
+9 IF '(($DATA(^XTMP(EVENT,"DISCHARGE")))!($DATA(^XTMP(EVENT,"MOVEMENT")))!($DATA(^XTMP(EVENT,"SERVICE")))!($DATA(^XTMP(EVENT,"SERVICE46"))))
SET EXIT=1
QUIT
+10 DO WHPTF(.CODELIST,.PROVARR,DFN)
End DoDot:2
if $GET(EXIT)
QUIT
End DoDot:1
if $GET(EXIT)
QUIT
+11 IF (($GET(EVENT)="")!($GET(VISIT)=""))&($GET(GMPLIFN)>0)
Begin DoDot:1
+12 IF '$DATA(^AUPNPROB(GMPLIFN))
SET EXIT=1
QUIT
+13 DO WHPBL(.CODELIST,.PROVARR,GMPLIFN)
End DoDot:1
if $GET(EXIT)
QUIT
+14 IF '$DATA(CODELIST)
QUIT
+15 ;
+16 SET SENDMSG=0
SET STATUS=1
+17 FOR TAX="VA-WH CURRENTLY PREGNANT","VA-WH RECENTLY PREGNANT","VA-WH POSSIBLE PREGNANCY","VA-WH CURRENTLY LACTATING"
Begin DoDot:1
+18 SET TAXIEN=$ORDER(^PXD(811.2,"B",TAX,0))
if '+TAXIEN
QUIT
+19 SET CODESYS=""
+20 FOR
SET CODESYS=$ORDER(CODELIST(CODESYS))
if (CODESYS="")!(STATUS'=1)
QUIT
Begin DoDot:2
+21 IF '$DATA(^PXD(811.2,TAXIEN,20,"AE",CODESYS))
QUIT
+22 SET CODE=""
+23 FOR
SET CODE=$ORDER(CODELIST(CODESYS,CODE))
if (CODE="")!(STATUS'=1)
QUIT
Begin DoDot:3
+24 IF $DATA(^PXD(811.2,TAXIEN,20,"AE",CODESYS,CODE))
Begin DoDot:4
+25 SET STATUS=$$WHAPPL(DFN,$PIECE($PIECE(CODELIST(CODESYS,CODE),U,1),"|",1))
+26 IF STATUS'=1
QUIT
+27 SET SENDMSG=SENDMSG+1
+28 SET SENDMSG(SENDMSG)=TAX_U_CODESYS_"|"_CODE_"|"_CODELIST(CODESYS,CODE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
if STATUS'=1
QUIT
+29 IF (SENDMSG=0)!(STATUS'=1)
QUIT
+30 FOR CODE=1:1:SENDMSG
if $GET(CACHE)=-1
QUIT
Begin DoDot:1
+31 SET SEND=0
+32 IF SENDMSG(CODE)["PREGNAN"
Begin DoDot:2
+33 IF '$DATA(CACHE("PREGNANCY"))
Begin DoDot:3
+34 SET PXRMSDT=$PIECE($PIECE(SENDMSG(CODE),"|",3),U,1)
+35 DO WHEVAL(.CACHE,"VA-WH UPDATE PREGNANCY STATUS",.PXRMSDT)
End DoDot:3
+36 if CACHE=-1
QUIT
+37 IF ((SENDMSG(CODE)["CURRENTLY")!(SENDMSG(CODE)["POSSIBLE"))&((CACHE("PREGNANCY","STATE")'="PREGNANT")!((CACHE("PREGNANCY","STATE")="PREGNANT")&(CACHE("PREGNANCY","OUT DATED"))))
Begin DoDot:3
+38 SET SEND=1
SET ACODE=$PIECE($PIECE(SENDMSG(CODE),U,2),"|",2)
if ACODE=""
QUIT
+39 IF $DATA(SEND("ACODES1",SEND,ACODE))
QUIT
+40 SET SEND("ACODES1",SEND,ACODE)=""
SET SEND("ACODES2",SEND,CODE)=""
End DoDot:3
QUIT
+41 IF (SENDMSG(CODE)["RECENTLY")&((CACHE("PREGNANCY","STATE")="PREGNANT")&(CACHE("PREGNANCY","OUT DATED")=0))
Begin DoDot:3
+42 SET SEND=1
SET ACODE=$PIECE($PIECE(SENDMSG(CODE),U,2),"|",2)
if ACODE=""
QUIT
+43 IF $DATA(SEND("ACODES1",SEND,ACODE))
QUIT
+44 SET SEND("ACODES1",SEND,ACODE)=""
SET SEND("ACODES2",SEND,CODE)=""
End DoDot:3
End DoDot:2
+45 IF SENDMSG(CODE)["LACTATING"
Begin DoDot:2
+46 IF '$DATA(CACHE("LACTATION"))
Begin DoDot:3
+47 SET PXRMSDT=$PIECE($PIECE(SENDMSG(CODE),"|",3),U,1)
+48 DO WHEVAL(.CACHE,"VA-WH UPDATE LACTATION STATUS",.PXRMSDT)
End DoDot:3
+49 if CACHE=-1
QUIT
+50 IF CACHE("LACTATION","STATE")'="LACTATING"
Begin DoDot:3
+51 SET SEND=2
SET ACODE=$PIECE($PIECE(SENDMSG(CODE),U,2),"|",2)
if ACODE=""
QUIT
+52 IF $DATA(SEND("ACODES1",SEND,ACODE))
QUIT
+53 SET SEND("ACODES1",SEND,ACODE)=""
SET SEND("ACODES2",SEND,CODE)=""
End DoDot:3
End DoDot:2
+54 IF $DATA(SEND("ACODES2",SEND,CODE))
Begin DoDot:2
+55 IF '$DATA(MESSAGES(SEND,"PXRMPROV"))
Begin DoDot:3
+56 NEW PXRMPROV
+57 DO GETRECIPS^WVRPCPT1(.PXRMPROV,DFN,"CODE",$SELECT(SEND=1:"P",SEND=2:"L",1:""),0,$PIECE(SENDMSG(CODE),U,3))
+58 IF +$GET(PXRMPROV(0))=-1
Begin DoDot:4
+59 SET ERROR(1,0)="Error retrieving Women's Health managers: "_$PIECE(PXRMPROV(0),U,2)
+60 DO ERROR(.ERROR)
+61 KILL PXRMPROV
+62 MERGE PXRMPROV=PROVARR
End DoDot:4
+63 IF $ORDER(PXRMPROV(""))'=""
MERGE MESSAGES(SEND,"PXRMPROV")=PXRMPROV
End DoDot:3
+64 IF $DATA(MESSAGES(SEND,"PXRMPROV"))
Begin DoDot:3
+65 SET WHDATA("ID")=DFN_U_$SELECT(SEND=1:"P",SEND=2:"L",1:"")
+66 SET WHDATA("CODE")=$PIECE(SENDMSG(CODE),U,2)
+67 SET STATUS=$$SAVESRND^WVRPCPT1(.WHDATA)
+68 IF +STATUS=-1
SET ERROR(1,0)="Error saving status conflict notification data: "_$PIECE(STATUS,U,2)
DO ERROR(.ERROR)
+69 IF +STATUS<1
KILL MESSAGES(SEND)
End DoDot:3
End DoDot:2
End DoDot:1
+70 SET SEND=0
FOR
SET SEND=$ORDER(MESSAGES(SEND))
if '+SEND
QUIT
Begin DoDot:1
+71 NEW PXRMPROV
+72 MERGE PXRMPROV=MESSAGES(SEND,"PXRMPROV")
+73 DO TALERT(DFN,.PXRMPROV,SEND,$SELECT((SEND=1)&($GET(CACHE("PREGNANCY","MUC"))):2,1:0))
End DoDot:1
+74 QUIT
+75 ;
ERROR(ERROR) ;Send an email that an error occurred
+1 NEW CNT,DATA,INDEX,SOURCE
+2 SET CNT=$ORDER(ERROR("?"),-1)+1
SET ERROR(CNT,0)=""
+3 SET CNT=CNT+1
SET ERROR(CNT,0)="The contents of the XTMP global that triggered this error:"
+4 FOR SOURCE="^XTMP(EVENT)","WHDATA"
Begin DoDot:1
+5 IF $DATA(@SOURCE)
DO ACOPY^PXRMUTIL(SOURCE,"DATA()")
+6 SET INDEX=0
FOR
SET INDEX=$ORDER(DATA(INDEX))
if '+INDEX
QUIT
SET CNT=CNT+1
SET ERROR(CNT,0)=DATA(INDEX)
+7 KILL DATA
End DoDot:1
+8 IF $GET(PTYPE)'=""
SET CNT=CNT+1
SET ERROR(CNT,0)="PTYPE="_PTYPE
+9 KILL ^TMP("PXRMXMZ",$JOB)
+10 MERGE ^TMP("PXRMXMZ",$JOB)=ERROR
+11 DO SEND^PXRMMSG("PXRMXMZ","Clinical Reminder Code Listener")
+12 KILL ^TMP("PXRMXMZ",$JOB)
+13 QUIT
WHAPPL(DFN,PXRMSDT) ;Determine if code is applicable for the given date
+1 ; $$WHAPPL: -1 => error
+2 ; 0 => not applicable
+3 ; 1 => applicable
+4 NEW NAME,RIEN,NODE,RNAME,DEFARR,FIEV,STATUS
+5 KILL ^TMP("PXRHM",$JOB)
+6 SET NAME="VA-WH POTENTIALLY UNSAFE MEDICATIONS REPORT - COHORT"
+7 SET RIEN=$ORDER(^PXD(811.9,"B",NAME,""))
IF RIEN'>0
QUIT -1
+8 SET NODE=$GET(^PXD(811.9,RIEN,0))
+9 SET RNAME=$SELECT($PIECE(NODE,U,3)'="":$PIECE(NODE,U,3),1:$PIECE(NODE,U))
+10 DO DEF^PXRMLDR(RIEN,.DEFARR)
+11 DO EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,.PXRMSDT)
+12 SET STATUS=$PIECE($GET(^TMP("PXRHM",$JOB,RIEN,RNAME)),U)
+13 KILL ^TMP("PXRHM",$JOB)
+14 IF (STATUS="CNBD")!(STATUS="ERROR")
QUIT -1
+15 IF $$STATMTCH^PXRMORCH(STATUS,"N")
QUIT 0
+16 QUIT 1
WHEVAL(CACHE,NAME,PXRMSDT) ;Evaluate pregancy or lactation reminder
+1 NEW RIEN,STATUS,SUB,FIND,DOC,DATE,EDD
+2 KILL ^TMP("PXRHM",$JOB)
+3 SET RIEN=$ORDER(^PXD(811.9,"B",NAME,""))
if RIEN<0
QUIT
+4 SET NODE=$GET(^PXD(811.9,RIEN,0))
if NODE=""
QUIT
+5 SET RNAME=$SELECT($PIECE(NODE,U,3)'="":$PIECE(NODE,U,3),1:$PIECE(NODE,U))
if RNAME=""
QUIT
+6 DO MAINDF^PXRM(DFN,RIEN,1,PXRMSDT)
+7 SET STATUS=$PIECE($GET(^TMP("PXRHM",$JOB,RIEN,RNAME)),U)
+8 IF (STATUS="CNBD")!(STATUS="ERROR")
SET CACHE=-1
QUIT
+9 SET SUB=$PIECE($PIECE(NAME,"VA-WH UPDATE ",2)," ")
IF SUB=""
SET CACHE=-1
QUIT
+10 SET FIND=$SELECT(SUB="PREGNANCY":3,SUB="LACTATION":2,1:"")
IF FIND=""
SET CACHE=-1
QUIT
+11 SET CACHE(SUB,"STATE")=$GET(^TMP("PXRHM",$JOB,RIEN,"FIEVAL",FIND,1,SUB_" STATE"))
+12 SET DOC=$GET(^TMP("PXRHM",$JOB,RIEN,"FIEVAL",FIND,1,"DOCUMENTATION STATUS"))
+13 SET DATE=$GET(^TMP("PXRHM",$JOB,RIEN,"FIEVAL",FIND,1,"DATE"))
+14 SET CACHE(SUB,"OUT DATED")=0
+15 IF DOC'="NO DOCUMENTATION"
IF $$STATMTCH^PXRMORCH(STATUS,"D")
Begin DoDot:1
+16 IF SUB="PREGNANCY"
Begin DoDot:2
+17 IF DOC="INCOMPLETE"
Begin DoDot:3
+18 IF CACHE(SUB,"STATE")="PREGNANT"
Begin DoDot:4
+19 SET EDD=$GET(^TMP("PXRHM",$JOB,RIEN,"FIEVAL",FIND,1,"EDD"))
+20 IF EDD=""
SET EDD=$$NEWDATE^PXRMDATE($GET(^TMP("PXRHM",$JOB,RIEN,"FIEVAL",FIND,1,"LAST MENSTRUAL PERIOD DATE")),"+","40W")
+21 IF EDD<DT
SET CACHE(SUB,"OUT DATED")=1
End DoDot:4
+22 IF CACHE(SUB,"STATE")'="PREGNANT"
IF DATE<$$NEWDATE^PXRMDATE(DT,"-","1Y")
SET CACHE(SUB,"OUT DATED")=1
End DoDot:3
+23 IF DOC="COMPLETE"
SET CACHE(SUB,"OUT DATED")=1
End DoDot:2
+24 IF SUB="LACTATION"
SET CACHE(SUB,"OUT DATED")=1
End DoDot:1
+25 IF SUB="PREGNANCY"
SET CACHE(SUB,"MUC")=$GET(^TMP("PXRHM",$JOB,RIEN,"FIEVAL",1))
+26 KILL ^TMP("PXRHM",$JOB)
+27 SET CACHE=1
+28 QUIT
+29 ;
WHICD(CODELIST,PROVARR,EVENT,VISIT) ;Retrieve data from ^XTMP
+1 NEW POVIEN,AFTER,BEFORE,CODEIEN,CODE,CODESYS,PRVIEN,PROVIEN,CDATE,ODATE
+2 NEW DIVISION
+3 SET CDATE=$PIECE($GET(^XTMP(EVENT,VISIT,"VST",VISIT,0,"AFTER")),U)
SET POVIEN=""
+4 SET ODATE=$PIECE($GET(^XTMP(EVENT,VISIT,"VST",VISIT,0,"AFTER")),U,13)
+5 SET DIVISION=$PIECE($GET(^XTMP(EVENT,VISIT,"VST",VISIT,0,"AFTER")),U,6)
+6 FOR
SET POVIEN=$ORDER(^XTMP(EVENT,VISIT,"POV",POVIEN))
if POVIEN=""
QUIT
Begin DoDot:1
+7 SET AFTER=$GET(^XTMP(EVENT,VISIT,"POV",POVIEN,0,"AFTER"))
+8 SET BEFORE=$GET(^XTMP(EVENT,VISIT,"POV",POVIEN,0,"BEFORE"))
+9 IF (AFTER=BEFORE)!(AFTER="")
QUIT
+10 SET CODEIEN=$PIECE(AFTER,U,1)
+11 DO ADDICD(.CODELIST,CODEIEN,CDATE,ODATE,DIVISION)
End DoDot:1
+12 SET PRVIEN=0
+13 FOR
SET PRVIEN=$ORDER(^XTMP(EVENT,VISIT,"PRV",PRVIEN))
if PRVIEN'>0
QUIT
Begin DoDot:1
+14 SET AFTER=$GET(^XTMP(EVENT,VISIT,"PRV",PRVIEN,0,"AFTER"))
+15 SET PROVIEN=+$PIECE(AFTER,U,1)
IF PROVIEN>0
SET PROVARR(PROVIEN)=""
End DoDot:1
+16 QUIT
+17 ;
WHPBL(CODELIST,PROVARR,GMPLIFN) ;Retrieve data from ^AUPNPROB
+1 NEW NODE1,PIECE,PROVIEN,CODEIEN,CDATE,ODATE,DIVISION
+2 IF $PIECE($GET(^AUPNPROB(GMPLIFN,1)),U,2)="H"
QUIT
+3 SET CDATE=$PIECE($GET(^AUPNPROB(GMPLIFN,802)),U)
+4 SET ODATE=$PIECE($GET(^AUPNPROB(GMPLIFN,0)),U,3)
+5 SET CODE=$PIECE($GET(^AUPNPROB(GMPLIFN,800)),U)
+6 SET DIVISION=$PIECE($GET(^AUPNPROB(GMPLIFN,0)),U,6)
+7 IF CODE'=""
SET CODELIST("SCT",CODE)=CDATE_$SELECT(ODATE'="":"|"_ODATE,1:"")_$SELECT(DIVISION'="":U_DIVISION,1:"")
+8 SET CODEIEN=$PIECE($GET(^AUPNPROB(GMPLIFN,0)),U)
+9 DO ADDICD(.CODELIST,CODEIEN,CDATE,ODATE,DIVISION)
+10 SET NODE1=$GET(^AUPNPROB(GMPLIFN,1))
+11 FOR PIECE=3:1:5
SET PROVIEN=+$PIECE(NODE1,U,PIECE)
IF PROVIEN>0
SET PROVARR(PROVIEN)=""
+12 QUIT
+13 ;
WHPTF(CODELIST,PROVARR,DFN) ;Retrieve data from ^XTMP
+1 NEW TYPE,FIELD,VAIN,VAERR,DATE,BEFORE,AFTER
+2 SET DATE=$GET(^XTMP(EVENT,"INTEREST DATE"))
SET TYPE=""
+3 FOR
SET TYPE=$ORDER(^XTMP(EVENT,TYPE))
if TYPE=""
QUIT
SET FIELD=""
FOR
SET FIELD=$ORDER(^XTMP(EVENT,TYPE,FIELD))
if FIELD=""
QUIT
Begin DoDot:1
+4 if FIELD="IENS"
QUIT
+5 SET AFTER=$GET(^XTMP(EVENT,TYPE,FIELD,"NEW"))
+6 SET BEFORE=$GET(^XTMP(EVENT,TYPE,FIELD,"OLD"))
+7 IF (AFTER=BEFORE)!(AFTER="")
QUIT
+8 DO ADDICD(.CODELIST,AFTER,DATE,$GET(^XTMP(EVENT,"OCCURRED DATE")),$GET(^XTMP(EVENT,"INSTITUTION")))
End DoDot:1
+9 if '$DATA(CODELIST)
QUIT
+10 IF $GET(^XTMP(EVENT,"PRIMARY PROVIDER"))>0
SET PROVARR(^XTMP(EVENT,"PRIMARY PROVIDER"))=""
+11 IF $GET(^XTMP(EVENT,"ATTENDING PHYSICIAN"))>0
SET PROVARR(^XTMP(EVENT,"ATTENDING PHYSICIAN"))=""
+12 QUIT
ADDICD(CODELIST,CODEIEN,CODEDATE,OCCURDATE,DIVISION) ;Add ICD code to the CODELIST array
+1 NEW CODE,CODESYS
+2 SET CODE=$$CODEC^ICDEX(80,CODEIEN)
+3 IF $PIECE(CODE,U,1)=-1
QUIT
+4 SET CODESYS=$PIECE($$CODECS^ICDEX(CODE,80,CODEDATE),U)
+5 SET CODESYS=$SELECT(CODESYS=1:"ICD",CODESYS=30:"10D",1:"")
+6 IF CODESYS=""
QUIT
+7 SET CODELIST(CODESYS,CODE)=CODEDATE_$SELECT($GET(OCCURDATE)'="":"|"_OCCURDATE,1:"")_$SELECT($GET(DIVISION)'="":U_DIVISION,1:"")
+8 QUIT
