WVUTL11 ;ISP/RFR - TERATOGENIC DRUGS UTILITY FUNCTIONS;Dec 01, 2020@12:32
;;1.0;WOMEN'S HEALTH;**24,26**;Sep 30, 1998;Build 624
Q
BC(WVDFN,WVDT) ;Return patient's likelihood of becoming pregnant
; when on prescription contraceptives
; DT^DILF (IA #2054): This component converts a user-formatted date into FileMan date format
; DATA^PSS50 (IA #4533): This component returns DRUG file (#50) data
; OCL^PSOORRL (IA #2400): This component returns all medications for a patient in a date range
; INPUT: WVDFN - IEN from PATIENT file #2
; WVDT - Date to use as today's date
; OUTPUT: 1 - HIGH, 2 - LOW
N WV100,WV465,WVCODE,WVDATE,WVRX,WVDRUG,WVRISK,WVON,WVNODE,X1,X2,X,%H
N BDT1,DRG,EXDT,FL,I,IEN,II,ITFN,J,LSTDS,LSTFD,LSTRD,MDR,MIG,MR,PSBDT,PSEDT,PSOR,RX0,RX2,RX3,SC,SCH,SG,ST,ST0,STA,TFN,TRM
S X1=WVDT,X2=-100 D C^%DTC S WV100=X ; Oldest dispense date for patient to be low risk
S X1=WVDT,X2=-465 D C^%DTC S WV465=X ; Start date for search
D ITEMLIST^PXRMAPI("","VA-WH HIRISK CONTRACEPTIVES GROUP","P","WVLIST")
D OCL^PSOORRL(WVDFN,WV465,WVDT)
M ^TMP("WVPS",$J)=^TMP("PS",$J) K ^TMP("PS",$J)
S WVRISK=1
S WVON="" F S WVON=$O(^TMP("WVPS",$J,WVON)) Q:WVON=""!($G(WVRISK)=2) D
.S WVNODE=$G(^TMP("WVPS",$J,WVON,0)) Q:WVNODE=""
.;CLINIC MEDICATIONS ARE EXPIRED WHEN GIVEN, ACTIVE WHEN FINISHED
.Q:$P(WVNODE,U)[";I"&($P(WVNODE,U,9)'="EXPIRED")
.S WVDATE=$S($P(WVNODE,U)[";O":$P(WVNODE,U,10),$P(WVNODE,U)[";I":$P(WVNODE,U,4),1:0)
.I WVDATE>=WV100 D OEL^PSOORRL(WVDFN,$P(WVNODE,U)) F WVDRUG=1:1:$G(^TMP("PS",$J,"DD",0)) D
..S WVDRUG(1)=$P($G(^TMP("PS",$J,"DD",WVDRUG,0)),U)
..D DATA^PSS50(WVDRUG(1),"","","","","WVTDPD")
..I $D(^TMP($J,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",$P($G(^TMP($J,"WVTDPD",WVDRUG(1),20)),U)_";PSNDF(50.6,")) S WVRISK=2
..I $D(^TMP($J,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",$P($G(^TMP($J,"WVTDPD",WVDRUG(1),25)),U)_";PS(50.605,")) S WVRISK=2
..I $D(^TMP($J,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",$P($G(^TMP($J,"WVTDPD",WVDRUG(1),22)),U)_";PSNDF(50.68,")) S WVRISK=2
..I $D(^TMP($J,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",WVDRUG(1)_";PSDRUG(")) S WVRISK=2
K ^TMP($J,"WVTDPD"),^TMP($J,"WVLIST"),^TMP("PS",$J),^TMP("WVPS",$J)
Q WVRISK
COBP(WVDFN,WVPIEN) ;Determine patient's likelihood of becomming pregnant
; INPUT: WVDFN - IEN from PATIENT file #2
; WVPIEN - IEN in PREGNANCY STATUSES sub-file #790.05
; OUTPUT: -1 - Error (message text in second caret piece)
; 0 - Unknown risk of pregnancy
; 1 - High risk of pregnancy
; 2 - Low risk of pregnancy
N WVRETURN,WVIEN,WVERR,WVRISK
S WVRETURN=0
S WVIEN=0 F S WVIEN=$O(^WV(790,WVDFN,4,WVPIEN,3,WVIEN)) Q:'WVIEN!($G(WVERR)) D
.N WVCONT
.S WVCONT=$P($G(^WV(790,WVDFN,4,WVPIEN,3,WVIEN,0)),U)
.S WVRISK(1)=$$MOA(WVCONT,WVDFN)
.I WVRISK(1)=-1 S WVERR=$P($G(^WV(791,WVCONT,0)),U) Q
.I $G(WVRISK)="" S WVRISK=WVRISK(1)
.I $G(WVRISK)'="",WVRISK(1)>WVRISK S WVRISK=WVRISK(1)
.K WVRISK(1)
I $G(WVERR)'="" S WVRETURN=-1_U_"Unknown pregnancy risk for "_WVERR
I $G(WVERR)="",$G(WVRISK)'="" S WVRETURN=WVRISK
Q WVRETURN
FMERROR(WVRESULT) ;RETURN FILEMAN ERROR MESSAGE AS STRING
N WVITM,WVERRTXT,WVERRNUM,WVERRORS
S WVERRNUM=0 F S WVERRNUM=$O(WVRESULT("DIERR",WVERRNUM)) Q:'+WVERRNUM D
.Q:$D(WVERRORS($G(WVRESULT("DIERR",WVERRNUM))))
.S WVITM=0 F S WVITM=$O(WVRESULT("DIERR",WVERRNUM,"TEXT",WVITM)) Q:WVITM="" D
..S WVERRTXT=$S($G(WVERRTXT)'="":WVERRTXT_" ",1:"")_WVRESULT("DIERR",WVERRNUM,"TEXT",WVITM)
.S WVERRORS=$G(WVRESULT("DIERR",WVERRNUM))
.I WVERRORS'="" S WVERRORS(WVERRORS)=""
Q $G(WVERRTXT)
ISREG(WVDFN) ;DETERMINE IF PATIENT IS REGISTERED
; INPUT: WVDFN - IEN IN WV PATIENT FILE [REQUIRED]
; OUTPUT: $$ISREG - 1: PATIENT IS/WAS SUCCESSFULLY REGISTERED
; 0^MESSAGE: PATIENT IS/WAS NOT SUCCESSFULLY REGISTERED
N WVNPFLAG
I $G(WVDFN)'?1.N D Q WVNPFLAG
.S WVNPFLAG=0_U_"Invalid patient identifier: """_$G(WVDFN)_"""."
I '$D(^WV(790,WVDFN)) D Q WVNPFLAG
.I "^f^F^"'[(U_$P($G(^DPT(WVDFN,0)),U,2)_U) S WVNPFLAG=0_U_"The specified patient is not a female." Q
.N WVERRADD,WVEXTRA
.I $D(^WV(790.02,DUZ(2),0))=1 D AUTOADD^WVPATE(WVDFN,DUZ(2),.WVERRADD)
.I $D(^WV(790.02,DUZ(2),0))'=1 S WVEXTRA=" and the "_$$GET1^DIQ(4,DUZ(2)_",",.01)_" institution is not configured in the Women's Health package",WVERRADD=0
.I +$G(WVERRADD)>0 S WVNPFLAG=1
.E S WVNPFLAG=0_U_"The specified patient is not in the WV PATIENT file"_$G(WVEXTRA)_"."
Q 1
VISITIEN(WVDFN,WVVSTR) ;RETURN VISIT FILE IEN GIVEN TIU VSTRING
S WVDFN=+$G(WVDFN),WVVSTR=$G(WVVSTR)
I ('WVDFN)!('$D(^DPT(WVDFN))) Q 0
I WVVSTR'?1.N1";"7N.1".".N1";"1U Q 0
N WVDT
S WVDT=+$P(WVVSTR,";",2),WVDT=(9999999-$P(WVDT,"."))_"."_$P(WVDT,".",2)
I $P(WVDT,".",2)="" S WVDT=$P(WVDT,".")
Q +$O(^AUPNVSIT("AA",WVDFN,WVDT,0))
VSTRING(WVIEN) ;RETURN TIU VSTRING GIVEN VISIT FILE IEN
S WVIEN=+$G(WVIEN)
Q:'WVIEN ""
N VSIT0
S VSIT0=$G(^AUPNVSIT(WVIEN,0))
Q +$P(VSIT0,U,22)_";"_+$P(VSIT0,U)_";"_$P(VSIT0,U,7)
ISPREG(WVDFN,WVSDATE,WVEDATE,WVCDE) ;DETERMINES IF PATIENT WAS PREGNANT ON DATE OR IN
; DATE RANGE
;INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
; WVSDATE - START DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
; DEFAULT: TODAY'S DATE
; WVEDATE - END DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
; NO DEFAULT VALUE
; WVCDE - SEE PREGS LINE TAG FOR DESCRIPTION
;OUTPUT: $$ISPREG=1 - PREGNANT
; 0 - NOT PREGNANT (INCLUDES ALL STATUSES EXCEPT PREGNANT)
I $G(WVFKST) Q 1
Q $$ISIT(4,WVDFN,$G(WVSDATE,DT),$G(WVEDATE),+$G(WVCDE))
ISLACT(WVDFN,WVSDATE,WVEDATE,WVCDE) ;DETERMINE IF PATIENT WAS LACTATING ON DATE OR IN
; DATE RANGE
;INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
; WVSDATE - START DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
; DEFAULT: TODAY'S DATE
; WVEDATE - END DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
; NO DEFAULT VALUE
; WVCDE - SEE LACTS LINE TAG FOR DESCRIPTION
;OUTPUT: $$ISLACT=1 - LACTATING
; 0 - NOT LACTATING
I $G(WVFKST) Q 1
Q $$ISIT(5,WVDFN,$G(WVSDATE,DT),$G(WVEDATE),+$G(WVCDE))
ISIT(WVNODE,WVDFN,WVSDATE,WVEDATE,WVCDE,WVRIEN) ;RETURNS PATIENT'S STATUS BASED ON TYPE AND
; DATE RANGE
;INPUT: WVNODE - SUBSCRIPT UNDER ^WV(790,WVDFN) THAT CONTAINS STATUS
; WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
; WVSDATE - START DATE OF INTEREST IN FILEMAN FORMAT [REQUIRED]
; WVEDATE - END DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
; WVCDE - SEE PREGS OR LACTS LINE TAGS FOR DESCRIPTION [OPTIONAL]
; WVRIEN - RETURN IEN OF LAST RECORD ASSOCIATED WITH THE PERIOD [OPTIONAL]
Q:+$G(WVSDATE)=0 0
N WVVISIT,WVDATE,WVIEN,WVINDEX,WVRTN,WVRECS,WVREC,WVINAME
S WVNODE=+$G(WVNODE),WVCDE=+$G(WVCDE)
S WVINAME=$S(WVNODE=4:"APREG",WVNODE=5:"ALACT",1:"") Q:WVINAME="" 0
I WVCDE D
.I WVNODE=4 D PREGS(WVDFN,.WVINDEX,.WVCDE)
.I WVNODE=5 D LACTS(WVDFN,.WVINDEX,.WVCDE)
I '$D(WVINDEX),$D(^WV(790,WVDFN,WVNODE,WVINAME)) M WVINDEX=^WV(790,WVDFN,WVNODE,WVINAME)
Q:'$D(WVINDEX) 0
S WVRTN=0,WVRIEN=+$G(WVRIEN)
S WVDATE(1)="" F S WVDATE(1)=$O(WVINDEX(WVDATE(1))) Q:WVDATE(1)=""!($D(WVRECS(1))) D
.S WVDATE(2)=$O(WVINDEX(WVDATE(1),"")) Q:WVDATE(2)=""
.S WVDATE("LAST_START")=WVDATE(1)
.I WVSDATE>=WVDATE(1),WVSDATE<=WVDATE(2) S WVRECS(1)=+$O(WVINDEX(WVDATE(1),WVDATE(2),0))
I '$D(WVRECS(1)),WVSDATE>WVDATE(2) S WVRECS(1)=+$O(WVINDEX(WVDATE("LAST_START"),WVDATE(2),0))_U_$S(WVNODE=4:0,1:"")
K WVDATE("LAST_START")
I +$G(WVRECS(1))>0,$P(WVRECS(1),U,2)="" S $P(WVRECS(1),U,2)=+$P($G(^WV(790,WVDFN,WVNODE,+WVRECS(1),2)),U)
I +$G(WVEDATE)>0 D
.S WVDATE(1)="" F S WVDATE(1)=$O(WVINDEX(WVDATE(1))) Q:WVDATE(1)=""!($D(WVRECS(2))) D
..S WVDATE(2)=$O(WVINDEX(WVDATE(1),"")) Q:WVDATE(2)=""
..S WVDATE("LAST_START")=WVDATE(1)
..I WVEDATE>=WVDATE(1),WVEDATE<=WVDATE(2) S WVRECS(2)=+$O(WVINDEX(WVDATE(1),WVDATE(2),0))
.I '$D(WVRECS(2)),WVEDATE>WVDATE(2) S WVRECS(2)=+$O(WVINDEX(WVDATE("LAST_START"),WVDATE(2),0))_U_$S(WVNODE=4:0,1:"")
I +$G(WVRECS(2))>0,$P($G(WVRECS(1)),U,2)="" S $P(WVRECS(2),U,2)=+$P($G(^WV(790,WVDFN,WVNODE,+WVRECS(2),2)),U)
F WVREC=1:1:2 I $D(WVRECS(WVREC)),$P($G(WVRTN),U)'=1 S WVRTN=$P(WVRECS(WVREC),U,2)_$S(WVRIEN=1:U_$P(WVRECS(WVREC),U),1:"")
I "^0^1^"'[(U_$P(WVRTN,U)_U) S $P(WVRTN,U)=0
Q WVRTN
PREGS(WVDFN,WVINDEX,WVCDE) ;CREATES INDEX OF PREGNANCY STATUSES
; INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
; WVINDEX - REFERENCE TO ARRAY IN WHICH TO RETURN THE INDEX OF STATUSES
; WVCDE - CALCULATE END DATE; FOR PREGNANCIES THAT DO NOT HAVE A SPECIFIED
; END DATE BUT HAVE A "NO LONGER PREGNANT" STATUS FOLLOWING IT,
; WVCDE=1 WILL SET THAT PREGNANCY'S END DATE TO TOMORROW
; AND WVCDE=0 WILL SET THAT PREGNANCY'S END DATE TO THE
; "NO LONGER PREGNANT" STATUS' D/T ENTERED. WVCDE=1 IS USED
; BY DIALOGS TO PROMPT FOR END OF PREGNANCY DATA
; OUTPUT: WVINDEX(START,STOP,STOP_IEN)=""
N WVDATE,WVIEN,WVSTART,WVEDD,WVEND,WVSAVE,WVNODE,WVSTATUS
S WVCDE=+$G(WVCDE)
S WVSAVE=$S(WVCDE=0:1,1:0),(WVSTART,WVEDD,WVEND)=0,WVNODE=4
S WVDATE="" F S WVDATE=$O(^WV(790,WVDFN,WVNODE,"B",WVDATE)) Q:WVDATE="" S WVIEN="" F S WVIEN=$O(^WV(790,WVDFN,WVNODE,"B",WVDATE,WVIEN)) Q:WVIEN="" D
.Q:$P($G(^WV(790,WVDFN,WVNODE,WVIEN,0)),U,6)=1
.S WVSTATUS=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U)
.I (WVSTATUS'=1)!(+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4)>0) D
..I WVEND>0 S WVIEN("CONT-END")=WVIEN I '$D(WVEND("GUESS")) Q
..I WVSTART>0,WVEDD>0 K WVINDEX(WVSTART,WVEDD) S WVEDD=0
..S WVEND=+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4),WVIEN("END")=WVIEN
..I WVEND>0 D Q
...S WVEND=+$$FMADD^XLFDT(WVEND,-1)
...I $G(WVEND("GUESS"))>0 K WVINDEX(WVSTART,+$$FMADD^XLFDT(WVEND("GUESS"),-1)),WVEND("GUESS")
...I WVSTART=0 D
....S WVINDEX(1410102,WVEND,WVIEN)=""
...I WVSTART>0 D
....S WVINDEX(WVSTART,WVEND,$S(+$G(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))="",WVSTART=0 K WVIEN("START"),WVIEN("CONT-START")
...S WVEND=$S(WVSTATUS=1:0,1:$$FMADD^XLFDT(WVEND,1))
..I WVEND=0 D
...I WVSTART=0 S WVEND=$P(WVDATE,".")
...I WVSTART>0 D
....Q:$G(WVEND("GUESS"))>0
....S WVEND("GUESS")=$S(WVCDE:+$$FMADD^XLFDT(DT,1),1:+$$FMADD^XLFDT($P(WVDATE,"."),-1))
....I WVSTART<=WVEND("GUESS") D Q
.....S WVINDEX(WVSTART,WVEND("GUESS"),$S(+$G(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))=""
.....K WVIEN("CONT-START")
.....S WVEND("GUESS")=+$$FMADD^XLFDT(WVEND("GUESS"),1)
....I WVSTART>WVEND("GUESS") S WVSTART=0,WVEND=$P(WVDATE,".") K WVEND("GUESS"),WVIEN("START") Q
.I WVSTATUS=1 D
..I WVSTART>0 D
...I $D(WVEND("GUESS")) S WVSTART=0 Q
...S WVSTART("OLD")=WVSTART,WVSTART=+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U)
...I WVSTART=0 S WVSTART=$P(WVDATE,".") Q:WVSTART=0
...S WVEDD("OLD")=WVEDD,WVEDD=+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2)
...I WVEDD>0 S WVEDD=+$$FMADD^XLFDT(WVEDD,$$GETGRACD)
...I WVEDD=0 S WVEDD=+$$FMADD^XLFDT(WVSTART,(280+$$GETGRACD))
...I WVSTART=WVSTART("OLD") D
....I WVEDD=WVEDD("OLD") K WVINDEX(WVSTART,WVEDD) S WVIEN("START")=WVIEN
....I WVEDD'=WVEDD("OLD") K WVINDEX(WVSTART,WVEDD("OLD"))
...I WVSTART'=WVSTART("OLD") D
....I WVSTART<WVEDD("OLD") D
.....K WVINDEX(WVSTART("OLD"),WVEDD("OLD"))
.....S WVEDD("OLD")=+$$FMADD^XLFDT(WVSTART,-1)
.....S WVINDEX(WVSTART("OLD"),WVEDD("OLD"),WVIEN("START"))=""
.....S WVIEN("START")=WVIEN
....I WVSTART=WVEDD("OLD") S WVIEN("CONT-START")=WVIEN
...K WVSTART("OLD"),WVEDD("OLD")
...I $G(WVIEN("CONT-START"))>0 Q
...S WVINDEX(WVSTART,WVEDD,WVIEN)=""
..I WVSTART=0 D
...S WVSTART=+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U)
...I WVSTART=0 S WVSTART=$P(WVDATE,".")
...S WVEDD=+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2),WVIEN("START")=WVIEN
...I (WVEND>0)!($G(WVEND("GUESS"))>0) D
....I WVEND=0 S WVEND=WVEND("GUESS")
....S WVSTART("INDEX")=$$FMADD^XLFDT(WVSTART,-1)
....I WVSTART("INDEX")>=WVEND S WVINDEX(WVEND,WVSTART("INDEX"),$S(+$G(WVIEN("CONT-END"))>0:WVIEN("CONT-END"),1:WVIEN("END")))=""
....S WVEND=0
....K WVIEN("END"),WVSTART("INDEX"),WVIEN("CONT-END"),WVEND("GUESS")
...I WVEDD>0 D
....S WVEDD=+$$FMADD^XLFDT(WVEDD,$$GETGRACD)
....S WVINDEX(WVSTART,WVEDD,WVIEN)=""
...I WVEDD=0 D
....S WVEDD=+$$FMADD^XLFDT(WVSTART,(280+$$GETGRACD))
....S WVINDEX(WVSTART,WVEDD,WVIEN)=""
I $G(WVEND("GUESS"))>0 S WVEND=WVEND("GUESS")
I WVEND>0 D
.S WVINDEX(WVEND,$S(WVEND<DT:DT,1:WVEND),$S($D(WVIEN("CONT-END"))=1:WVIEN("CONT-END"),1:WVIEN("END")))=""
I WVCDE,$G(WVSTATUS)=1,DT>WVEDD D
.K WVINDEX(WVSTART,WVEDD)
.S WVEDD=+$$FMADD^XLFDT(DT,1)
.S WVINDEX(WVSTART,WVEDD,WVIEN("START"))=""
I WVSAVE D
.K ^WV(790,WVDFN,WVNODE,"APREG")
.I $D(WVINDEX) M ^WV(790,WVDFN,WVNODE,"APREG")=WVINDEX
Q
GETGRACD() ;WRAPPER TO CALL GETGRACD^PXRMCWH1
;PXRM*2.0*45 INSTALLS AFTER WV*1.0*24
;REMOVE THIS LINE-TAG IF PATCHING THIS ROUTINE AFTER WV*1.0*24
I $T(GETGRACD^PXRMCWH1) Q $$GETGRACD^PXRMCWH1
Q 28
LACTS(WVDFN,WVINDEX,WVCDE) ;CREATES INDEX OF LACTATION STATUSES
; INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
; WVINDEX - REFERENCE TO ARRAY IN WHICH TO RETURN THE INDEX OF STATUSES
; WVCDE - CALCULATE END DATE; FOR LACTATIONS THAT DO NOT HAVE A SPECIFIED
; END DATE BUT HAVE A "NO LONGER LACTATING" STATUS FOLLOWING IT,
; WVCDE=1 WILL SET THAT LACTATION'S END DATE TO TOMORROW
; AND WVCDE=0 WILL SET THAT LACTATION'S END DATE TO THE
; "NO LONGER LACTATING" STATUS' D/T ENTERED. WVCDE=1 IS USED
; BY DIALOGS TO PROMPT FOR END OF LACTATION DATA
; OUTPUT: WVINDEX(START,STOP,STOP_IEN)=""
N WVDATE,WVIEN,WVSTART,WVEND,WVSAVE,WVNODE,WVSTATUS
S WVCDE=+$G(WVCDE)
S WVSAVE=$S(WVCDE=0:1,1:0),(WVSTART,WVEND)=0,WVNODE=5
S WVDATE="" F S WVDATE=$O(^WV(790,WVDFN,WVNODE,"B",WVDATE)) Q:WVDATE="" S WVIEN="" F S WVIEN=$O(^WV(790,WVDFN,WVNODE,"B",WVDATE,WVIEN)) Q:WVIEN="" D
.Q:$P($G(^WV(790,WVDFN,WVNODE,WVIEN,0)),U,6)=1
.S WVSTATUS=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U)
.I WVSTATUS=1 D
..I WVSTART>0 D
...I $D(WVEND("GUESS")) S WVSTART=0 Q
...S WVIEN("CONT-START")=WVIEN
..I WVSTART=0 D
...S WVSTART=$P(WVDATE,"."),WVIEN("START")=WVIEN
...I (WVEND>0)!($G(WVEND("GUESS"))>0) D
....I WVEND=0 S WVEND=+$$FMADD^XLFDT(WVEND("GUESS"),1)
....S WVSTART("INDEX")=$$FMADD^XLFDT(WVSTART,-1)
....I WVSTART("INDEX")>=WVEND S WVINDEX(WVEND,WVSTART("INDEX"),$S(+$G(WVIEN("CONT-END"))>0:WVIEN("CONT-END"),1:WVIEN("END")))=""
....S WVEND=0
....K WVEND("GUESS"),WVIEN("END"),WVSTART("INDEX"),WVIEN("CONT-END")
.I WVSTATUS=0 D
..I WVEND>0 S WVIEN("CONT-END")=WVIEN I '$D(WVEND("GUESS")) Q
..S WVEND=+$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,2),WVIEN("END")=WVIEN
..I WVEND>0 D Q
...I $G(WVEND("GUESS"))>0 K WVINDEX(WVSTART,WVEND("GUESS")),WVEND("GUESS")
...I WVSTART=0 D
....S WVINDEX(1410102,WVEND,WVIEN)=""
...I WVSTART>0 D
....S WVINDEX(WVSTART,WVEND,$S(+$G(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))="",WVSTART=0 K WVIEN("START"),WVIEN("CONT-START")
...S WVEND=$$FMADD^XLFDT(WVEND,1)
..I WVEND=0 D
...I WVSTART=0 S WVEND=$P($P($G(^WV(790,WVDFN,WVNODE,WVIEN,0)),U),".")
...I WVSTART>0 D
....Q:$G(WVEND("GUESS"))>0
....S WVEND("GUESS")=$S(WVCDE:+$$FMADD^XLFDT(DT,1),1:+$$FMADD^XLFDT($P(WVDATE,"."),-1))
....I WVSTART<=WVEND("GUESS") S WVINDEX(WVSTART,WVEND("GUESS"),$S(+$G(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))="" K WVIEN("CONT-START")
....I WVSTART>WVEND("GUESS") S WVSTART=0,WVEND("GUESS")=$S(WVCDE:DT,1:$P($P($G(^WV(790,WVDFN,WVNODE,WVIEN,0)),U),".")) K WVIEN("START") Q
I $G(WVEND("GUESS"))>0 S WVEND=+$$FMADD^XLFDT(WVEND("GUESS"),1)
I WVEND>0 D
.S WVINDEX(WVEND,$S(WVEND<DT:DT,1:WVEND),$S($D(WVIEN("CONT-END"))=1:WVIEN("CONT-END"),1:WVIEN("END")))=""
I WVSTART>0,WVEND=0 S WVINDEX(WVSTART,DT,$S($D(WVIEN("CONT-START"))=1:WVIEN("CONT-START"),1:WVIEN("START")))=""
I WVSAVE D
.K ^WV(790,WVDFN,WVNODE,"ALACT")
.I $D(WVINDEX) M ^WV(790,WVDFN,WVNODE,"ALACT")=WVINDEX
Q
MOA(WVMOA,WVDFN,WVDT) ;RETURN LIKELIHOOD OF BECOMING PREGNANT
; GIVEN THE METHOD OF CONTRACEPTION
; INPUT: WVMOA - CONTRACEPTIVE METHOD (NAME OR IEN IN FILE #791)
; WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
; WVDATE - DATE TO USE WHEN CALCULATING THE LIKELIHOOD
; OUTPUT: 1 - HIGH, 2 - LOW, -1 - Error
Q:$G(WVMOA)="" -1
N WVIEN,WVRETURN
S WVRETURN=-1,WVDT=$G(WVDT,DT),WVDT=$P(WVDT,".")
S WVIEN=$S(WVMOA'=+WVMOA:$O(^WV(791,"B",WVMOA,0)),1:WVMOA)
Q:'WVIEN WVRETURN
I $D(^WV(791,WVIEN,1)) X ^WV(791,WVIEN,1)
E S WVRETURN=$P($G(^WV(791,WVIEN,0)),U,2)
S:WVRETURN<1 WVRETURN=-1
Q WVRETURN
GETLREC(WVDFN,WVNODE) ;RETURN "IEN^DATE^ENTERED BY^STATUS" OF MOST RECENT PREGNANCY
; OR LACTATION STATUS RECORD
N WVRET,WVSTATUS,WVIEN
S WVRET=0
S WVSTATUS=$$ISIT^WVUTL11(WVNODE,WVDFN,DT,"",0,1)
S WVIEN=+$P(WVSTATUS,U,2),WVSTATUS=$P(WVSTATUS,U)
I WVIEN>0 D
.I 'WVSTATUS,WVNODE=4,$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U)=2 D
..S WVSTATUS=2
.S WVRET=WVIEN_U_$P($G(^WV(790,WVDFN,WVNODE,WVIEN,0)),U,1,2)_U_WVSTATUS
Q WVRET
REM(WVDFN,WVNAME,WVFIEVAL) ;EVALUATE REMINDER DEFINITION
;RETURN: $$REM => EVAL STATUS
N WVPARAMS,WVRESULT,WVREMST
S WVFIEVAL=+$G(WVFIEVAL)
S WVPARAMS("SUB")="WV APPLICABLE",WVPARAMS("DFN")=WVDFN
S WVPARAMS("REMINDERS",WVNAME)=WVFIEVAL_U_5
D EN^PXRMGEV(.WVRESULT,.WVPARAMS)
I $P($G(^TMP($J,"WV APPLICABLE",0)),U)=-1 Q ^TMP($J,"WV APPLICABLE",0)
S WVREMST=$P($G(^TMP($J,"WV APPLICABLE",WVNAME)),U)
K:'WVFIEVAL ^TMP($J,"WV APPLICABLE")
I WVREMST="" Q -1_U_"Reminder "_WVNAME_" evaluation did not return a status."
Q WVREMST
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVUTL11 18034 printed Sep 23, 2025@20:24:27 Page 2
WVUTL11 ;ISP/RFR - TERATOGENIC DRUGS UTILITY FUNCTIONS;Dec 01, 2020@12:32
+1 ;;1.0;WOMEN'S HEALTH;**24,26**;Sep 30, 1998;Build 624
+2 QUIT
BC(WVDFN,WVDT) ;Return patient's likelihood of becoming pregnant
+1 ; when on prescription contraceptives
+2 ; DT^DILF (IA #2054): This component converts a user-formatted date into FileMan date format
+3 ; DATA^PSS50 (IA #4533): This component returns DRUG file (#50) data
+4 ; OCL^PSOORRL (IA #2400): This component returns all medications for a patient in a date range
+5 ; INPUT: WVDFN - IEN from PATIENT file #2
+6 ; WVDT - Date to use as today's date
+7 ; OUTPUT: 1 - HIGH, 2 - LOW
+8 NEW WV100,WV465,WVCODE,WVDATE,WVRX,WVDRUG,WVRISK,WVON,WVNODE,X1,X2,X,%H
+9 NEW BDT1,DRG,EXDT,FL,I,IEN,II,ITFN,J,LSTDS,LSTFD,LSTRD,MDR,MIG,MR,PSBDT,PSEDT,PSOR,RX0,RX2,RX3,SC,SCH,SG,ST,ST0,STA,TFN,TRM
+10 ; Oldest dispense date for patient to be low risk
SET X1=WVDT
SET X2=-100
DO C^%DTC
SET WV100=X
+11 ; Start date for search
SET X1=WVDT
SET X2=-465
DO C^%DTC
SET WV465=X
+12 DO ITEMLIST^PXRMAPI("","VA-WH HIRISK CONTRACEPTIVES GROUP","P","WVLIST")
+13 DO OCL^PSOORRL(WVDFN,WV465,WVDT)
+14 MERGE ^TMP("WVPS",$JOB)=^TMP("PS",$JOB)
KILL ^TMP("PS",$JOB)
+15 SET WVRISK=1
+16 SET WVON=""
FOR
SET WVON=$ORDER(^TMP("WVPS",$JOB,WVON))
if WVON=""!($GET(WVRISK)=2)
QUIT
Begin DoDot:1
+17 SET WVNODE=$GET(^TMP("WVPS",$JOB,WVON,0))
if WVNODE=""
QUIT
+18 ;CLINIC MEDICATIONS ARE EXPIRED WHEN GIVEN, ACTIVE WHEN FINISHED
+19 if $PIECE(WVNODE,U)[";I"&($PIECE(WVNODE,U,9)'="EXPIRED")
QUIT
+20 SET WVDATE=$SELECT($PIECE(WVNODE,U)[";O":$PIECE(WVNODE,U,10),$PIECE(WVNODE,U)[";I":$PIECE(WVNODE,U,4),1:0)
+21 IF WVDATE>=WV100
DO OEL^PSOORRL(WVDFN,$PIECE(WVNODE,U))
FOR WVDRUG=1:1:$GET(^TMP("PS",$JOB,"DD",0))
Begin DoDot:2
+22 SET WVDRUG(1)=$PIECE($GET(^TMP("PS",$JOB,"DD",WVDRUG,0)),U)
+23 DO DATA^PSS50(WVDRUG(1),"","","","","WVTDPD")
+24 IF $DATA(^TMP($JOB,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",$PIECE($GET(^TMP($JOB,"WVTDPD",WVDRUG(1),20)),U)_";PSNDF(50.6,"))
SET WVRISK=2
+25 IF $DATA(^TMP($JOB,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",$PIECE($GET(^TMP($JOB,"WVTDPD",WVDRUG(1),25)),U)_";PS(50.605,"))
SET WVRISK=2
+26 IF $DATA(^TMP($JOB,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",$PIECE($GET(^TMP($JOB,"WVTDPD",WVDRUG(1),22)),U)_";PSNDF(50.68,"))
SET WVRISK=2
+27 IF $DATA(^TMP($JOB,"WVLIST","VA-WH HIRISK CONTRACEPTIVES GROUP","P",WVDRUG(1)_";PSDRUG("))
SET WVRISK=2
End DoDot:2
End DoDot:1
+28 KILL ^TMP($JOB,"WVTDPD"),^TMP($JOB,"WVLIST"),^TMP("PS",$JOB),^TMP("WVPS",$JOB)
+29 QUIT WVRISK
COBP(WVDFN,WVPIEN) ;Determine patient's likelihood of becomming pregnant
+1 ; INPUT: WVDFN - IEN from PATIENT file #2
+2 ; WVPIEN - IEN in PREGNANCY STATUSES sub-file #790.05
+3 ; OUTPUT: -1 - Error (message text in second caret piece)
+4 ; 0 - Unknown risk of pregnancy
+5 ; 1 - High risk of pregnancy
+6 ; 2 - Low risk of pregnancy
+7 NEW WVRETURN,WVIEN,WVERR,WVRISK
+8 SET WVRETURN=0
+9 SET WVIEN=0
FOR
SET WVIEN=$ORDER(^WV(790,WVDFN,4,WVPIEN,3,WVIEN))
if 'WVIEN!($GET(WVERR))
QUIT
Begin DoDot:1
+10 NEW WVCONT
+11 SET WVCONT=$PIECE($GET(^WV(790,WVDFN,4,WVPIEN,3,WVIEN,0)),U)
+12 SET WVRISK(1)=$$MOA(WVCONT,WVDFN)
+13 IF WVRISK(1)=-1
SET WVERR=$PIECE($GET(^WV(791,WVCONT,0)),U)
QUIT
+14 IF $GET(WVRISK)=""
SET WVRISK=WVRISK(1)
+15 IF $GET(WVRISK)'=""
IF WVRISK(1)>WVRISK
SET WVRISK=WVRISK(1)
+16 KILL WVRISK(1)
End DoDot:1
+17 IF $GET(WVERR)'=""
SET WVRETURN=-1_U_"Unknown pregnancy risk for "_WVERR
+18 IF $GET(WVERR)=""
IF $GET(WVRISK)'=""
SET WVRETURN=WVRISK
+19 QUIT WVRETURN
FMERROR(WVRESULT) ;RETURN FILEMAN ERROR MESSAGE AS STRING
+1 NEW WVITM,WVERRTXT,WVERRNUM,WVERRORS
+2 SET WVERRNUM=0
FOR
SET WVERRNUM=$ORDER(WVRESULT("DIERR",WVERRNUM))
if '+WVERRNUM
QUIT
Begin DoDot:1
+3 if $DATA(WVERRORS($GET(WVRESULT("DIERR",WVERRNUM))))
QUIT
+4 SET WVITM=0
FOR
SET WVITM=$ORDER(WVRESULT("DIERR",WVERRNUM,"TEXT",WVITM))
if WVITM=""
QUIT
Begin DoDot:2
+5 SET WVERRTXT=$SELECT($GET(WVERRTXT)'="":WVERRTXT_" ",1:"")_WVRESULT("DIERR",WVERRNUM,"TEXT",WVITM)
End DoDot:2
+6 SET WVERRORS=$GET(WVRESULT("DIERR",WVERRNUM))
+7 IF WVERRORS'=""
SET WVERRORS(WVERRORS)=""
End DoDot:1
+8 QUIT $GET(WVERRTXT)
ISREG(WVDFN) ;DETERMINE IF PATIENT IS REGISTERED
+1 ; INPUT: WVDFN - IEN IN WV PATIENT FILE [REQUIRED]
+2 ; OUTPUT: $$ISREG - 1: PATIENT IS/WAS SUCCESSFULLY REGISTERED
+3 ; 0^MESSAGE: PATIENT IS/WAS NOT SUCCESSFULLY REGISTERED
+4 NEW WVNPFLAG
+5 IF $GET(WVDFN)'?1.N
Begin DoDot:1
+6 SET WVNPFLAG=0_U_"Invalid patient identifier: """_$GET(WVDFN)_"""."
End DoDot:1
QUIT WVNPFLAG
+7 IF '$DATA(^WV(790,WVDFN))
Begin DoDot:1
+8 IF "^f^F^"'[(U_$PIECE($GET(^DPT(WVDFN,0)),U,2)_U)
SET WVNPFLAG=0_U_"The specified patient is not a female."
QUIT
+9 NEW WVERRADD,WVEXTRA
+10 IF $DATA(^WV(790.02,DUZ(2),0))=1
DO AUTOADD^WVPATE(WVDFN,DUZ(2),.WVERRADD)
+11 IF $DATA(^WV(790.02,DUZ(2),0))'=1
SET WVEXTRA=" and the "_$$GET1^DIQ(4,DUZ(2)_",",.01)_" institution is not configured in the Women's Health package"
SET WVERRADD=0
+12 IF +$GET(WVERRADD)>0
SET WVNPFLAG=1
+13 IF '$TEST
SET WVNPFLAG=0_U_"The specified patient is not in the WV PATIENT file"_$GET(WVEXTRA)_"."
End DoDot:1
QUIT WVNPFLAG
+14 QUIT 1
VISITIEN(WVDFN,WVVSTR) ;RETURN VISIT FILE IEN GIVEN TIU VSTRING
+1 SET WVDFN=+$GET(WVDFN)
SET WVVSTR=$GET(WVVSTR)
+2 IF ('WVDFN)!('$DATA(^DPT(WVDFN)))
QUIT 0
+3 IF WVVSTR'?1.N1";"7N.1".".N1";"1U
QUIT 0
+4 NEW WVDT
+5 SET WVDT=+$PIECE(WVVSTR,";",2)
SET WVDT=(9999999-$PIECE(WVDT,"."))_"."_$PIECE(WVDT,".",2)
+6 IF $PIECE(WVDT,".",2)=""
SET WVDT=$PIECE(WVDT,".")
+7 QUIT +$ORDER(^AUPNVSIT("AA",WVDFN,WVDT,0))
VSTRING(WVIEN) ;RETURN TIU VSTRING GIVEN VISIT FILE IEN
+1 SET WVIEN=+$GET(WVIEN)
+2 if 'WVIEN
QUIT ""
+3 NEW VSIT0
+4 SET VSIT0=$GET(^AUPNVSIT(WVIEN,0))
+5 QUIT +$PIECE(VSIT0,U,22)_";"_+$PIECE(VSIT0,U)_";"_$PIECE(VSIT0,U,7)
ISPREG(WVDFN,WVSDATE,WVEDATE,WVCDE) ;DETERMINES IF PATIENT WAS PREGNANT ON DATE OR IN
+1 ; DATE RANGE
+2 ;INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
+3 ; WVSDATE - START DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
+4 ; DEFAULT: TODAY'S DATE
+5 ; WVEDATE - END DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
+6 ; NO DEFAULT VALUE
+7 ; WVCDE - SEE PREGS LINE TAG FOR DESCRIPTION
+8 ;OUTPUT: $$ISPREG=1 - PREGNANT
+9 ; 0 - NOT PREGNANT (INCLUDES ALL STATUSES EXCEPT PREGNANT)
+10 IF $GET(WVFKST)
QUIT 1
+11 QUIT $$ISIT(4,WVDFN,$GET(WVSDATE,DT),$GET(WVEDATE),+$GET(WVCDE))
ISLACT(WVDFN,WVSDATE,WVEDATE,WVCDE) ;DETERMINE IF PATIENT WAS LACTATING ON DATE OR IN
+1 ; DATE RANGE
+2 ;INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
+3 ; WVSDATE - START DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
+4 ; DEFAULT: TODAY'S DATE
+5 ; WVEDATE - END DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
+6 ; NO DEFAULT VALUE
+7 ; WVCDE - SEE LACTS LINE TAG FOR DESCRIPTION
+8 ;OUTPUT: $$ISLACT=1 - LACTATING
+9 ; 0 - NOT LACTATING
+10 IF $GET(WVFKST)
QUIT 1
+11 QUIT $$ISIT(5,WVDFN,$GET(WVSDATE,DT),$GET(WVEDATE),+$GET(WVCDE))
ISIT(WVNODE,WVDFN,WVSDATE,WVEDATE,WVCDE,WVRIEN) ;RETURNS PATIENT'S STATUS BASED ON TYPE AND
+1 ; DATE RANGE
+2 ;INPUT: WVNODE - SUBSCRIPT UNDER ^WV(790,WVDFN) THAT CONTAINS STATUS
+3 ; WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
+4 ; WVSDATE - START DATE OF INTEREST IN FILEMAN FORMAT [REQUIRED]
+5 ; WVEDATE - END DATE OF INTEREST IN FILEMAN FORMAT [OPTIONAL]
+6 ; WVCDE - SEE PREGS OR LACTS LINE TAGS FOR DESCRIPTION [OPTIONAL]
+7 ; WVRIEN - RETURN IEN OF LAST RECORD ASSOCIATED WITH THE PERIOD [OPTIONAL]
+8 if +$GET(WVSDATE)=0
QUIT 0
+9 NEW WVVISIT,WVDATE,WVIEN,WVINDEX,WVRTN,WVRECS,WVREC,WVINAME
+10 SET WVNODE=+$GET(WVNODE)
SET WVCDE=+$GET(WVCDE)
+11 SET WVINAME=$SELECT(WVNODE=4:"APREG",WVNODE=5:"ALACT",1:"")
if WVINAME=""
QUIT 0
+12 IF WVCDE
Begin DoDot:1
+13 IF WVNODE=4
DO PREGS(WVDFN,.WVINDEX,.WVCDE)
+14 IF WVNODE=5
DO LACTS(WVDFN,.WVINDEX,.WVCDE)
End DoDot:1
+15 IF '$DATA(WVINDEX)
IF $DATA(^WV(790,WVDFN,WVNODE,WVINAME))
MERGE WVINDEX=^WV(790,WVDFN,WVNODE,WVINAME)
+16 if '$DATA(WVINDEX)
QUIT 0
+17 SET WVRTN=0
SET WVRIEN=+$GET(WVRIEN)
+18 SET WVDATE(1)=""
FOR
SET WVDATE(1)=$ORDER(WVINDEX(WVDATE(1)))
if WVDATE(1)=""!($DATA(WVRECS(1)))
QUIT
Begin DoDot:1
+19 SET WVDATE(2)=$ORDER(WVINDEX(WVDATE(1),""))
if WVDATE(2)=""
QUIT
+20 SET WVDATE("LAST_START")=WVDATE(1)
+21 IF WVSDATE>=WVDATE(1)
IF WVSDATE<=WVDATE(2)
SET WVRECS(1)=+$ORDER(WVINDEX(WVDATE(1),WVDATE(2),0))
End DoDot:1
+22 IF '$DATA(WVRECS(1))
IF WVSDATE>WVDATE(2)
SET WVRECS(1)=+$ORDER(WVINDEX(WVDATE("LAST_START"),WVDATE(2),0))_U_$SELECT(WVNODE=4:0,1:"")
+23 KILL WVDATE("LAST_START")
+24 IF +$GET(WVRECS(1))>0
IF $PIECE(WVRECS(1),U,2)=""
SET $PIECE(WVRECS(1),U,2)=+$PIECE($GET(^WV(790,WVDFN,WVNODE,+WVRECS(1),2)),U)
+25 IF +$GET(WVEDATE)>0
Begin DoDot:1
+26 SET WVDATE(1)=""
FOR
SET WVDATE(1)=$ORDER(WVINDEX(WVDATE(1)))
if WVDATE(1)=""!($DATA(WVRECS(2)))
QUIT
Begin DoDot:2
+27 SET WVDATE(2)=$ORDER(WVINDEX(WVDATE(1),""))
if WVDATE(2)=""
QUIT
+28 SET WVDATE("LAST_START")=WVDATE(1)
+29 IF WVEDATE>=WVDATE(1)
IF WVEDATE<=WVDATE(2)
SET WVRECS(2)=+$ORDER(WVINDEX(WVDATE(1),WVDATE(2),0))
End DoDot:2
+30 IF '$DATA(WVRECS(2))
IF WVEDATE>WVDATE(2)
SET WVRECS(2)=+$ORDER(WVINDEX(WVDATE("LAST_START"),WVDATE(2),0))_U_$SELECT(WVNODE=4:0,1:"")
End DoDot:1
+31 IF +$GET(WVRECS(2))>0
IF $PIECE($GET(WVRECS(1)),U,2)=""
SET $PIECE(WVRECS(2),U,2)=+$PIECE($GET(^WV(790,WVDFN,WVNODE,+WVRECS(2),2)),U)
+32 FOR WVREC=1:1:2
IF $DATA(WVRECS(WVREC))
IF $PIECE($GET(WVRTN),U)'=1
SET WVRTN=$PIECE(WVRECS(WVREC),U,2)_$SELECT(WVRIEN=1:U_$PIECE(WVRECS(WVREC),U),1:"")
+33 IF "^0^1^"'[(U_$PIECE(WVRTN,U)_U)
SET $PIECE(WVRTN,U)=0
+34 QUIT WVRTN
PREGS(WVDFN,WVINDEX,WVCDE) ;CREATES INDEX OF PREGNANCY STATUSES
+1 ; INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
+2 ; WVINDEX - REFERENCE TO ARRAY IN WHICH TO RETURN THE INDEX OF STATUSES
+3 ; WVCDE - CALCULATE END DATE; FOR PREGNANCIES THAT DO NOT HAVE A SPECIFIED
+4 ; END DATE BUT HAVE A "NO LONGER PREGNANT" STATUS FOLLOWING IT,
+5 ; WVCDE=1 WILL SET THAT PREGNANCY'S END DATE TO TOMORROW
+6 ; AND WVCDE=0 WILL SET THAT PREGNANCY'S END DATE TO THE
+7 ; "NO LONGER PREGNANT" STATUS' D/T ENTERED. WVCDE=1 IS USED
+8 ; BY DIALOGS TO PROMPT FOR END OF PREGNANCY DATA
+9 ; OUTPUT: WVINDEX(START,STOP,STOP_IEN)=""
+10 NEW WVDATE,WVIEN,WVSTART,WVEDD,WVEND,WVSAVE,WVNODE,WVSTATUS
+11 SET WVCDE=+$GET(WVCDE)
+12 SET WVSAVE=$SELECT(WVCDE=0:1,1:0)
SET (WVSTART,WVEDD,WVEND)=0
SET WVNODE=4
+13 SET WVDATE=""
FOR
SET WVDATE=$ORDER(^WV(790,WVDFN,WVNODE,"B",WVDATE))
if WVDATE=""
QUIT
SET WVIEN=""
FOR
SET WVIEN=$ORDER(^WV(790,WVDFN,WVNODE,"B",WVDATE,WVIEN))
if WVIEN=""
QUIT
Begin DoDot:1
+14 if $PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,0)),U,6)=1
QUIT
+15 SET WVSTATUS=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U)
+16 IF (WVSTATUS'=1)!(+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4)>0)
Begin DoDot:2
+17 IF WVEND>0
SET WVIEN("CONT-END")=WVIEN
IF '$DATA(WVEND("GUESS"))
QUIT
+18 IF WVSTART>0
IF WVEDD>0
KILL WVINDEX(WVSTART,WVEDD)
SET WVEDD=0
+19 SET WVEND=+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4)
SET WVIEN("END")=WVIEN
+20 IF WVEND>0
Begin DoDot:3
+21 SET WVEND=+$$FMADD^XLFDT(WVEND,-1)
+22 IF $GET(WVEND("GUESS"))>0
KILL WVINDEX(WVSTART,+$$FMADD^XLFDT(WVEND("GUESS"),-1)),WVEND("GUESS")
+23 IF WVSTART=0
Begin DoDot:4
+24 SET WVINDEX(1410102,WVEND,WVIEN)=""
End DoDot:4
+25 IF WVSTART>0
Begin DoDot:4
+26 SET WVINDEX(WVSTART,WVEND,$SELECT(+$GET(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))=""
SET WVSTART=0
KILL WVIEN("START"),WVIEN("CONT-START")
End DoDot:4
+27 SET WVEND=$SELECT(WVSTATUS=1:0,1:$$FMADD^XLFDT(WVEND,1))
End DoDot:3
QUIT
+28 IF WVEND=0
Begin DoDot:3
+29 IF WVSTART=0
SET WVEND=$PIECE(WVDATE,".")
+30 IF WVSTART>0
Begin DoDot:4
+31 if $GET(WVEND("GUESS"))>0
QUIT
+32 SET WVEND("GUESS")=$SELECT(WVCDE:+$$FMADD^XLFDT(DT,1),1:+$$FMADD^XLFDT($PIECE(WVDATE,"."),-1))
+33 IF WVSTART<=WVEND("GUESS")
Begin DoDot:5
+34 SET WVINDEX(WVSTART,WVEND("GUESS"),$SELECT(+$GET(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))=""
+35 KILL WVIEN("CONT-START")
+36 SET WVEND("GUESS")=+$$FMADD^XLFDT(WVEND("GUESS"),1)
End DoDot:5
QUIT
+37 IF WVSTART>WVEND("GUESS")
SET WVSTART=0
SET WVEND=$PIECE(WVDATE,".")
KILL WVEND("GUESS"),WVIEN("START")
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+38 IF WVSTATUS=1
Begin DoDot:2
+39 IF WVSTART>0
Begin DoDot:3
+40 IF $DATA(WVEND("GUESS"))
SET WVSTART=0
QUIT
+41 SET WVSTART("OLD")=WVSTART
SET WVSTART=+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U)
+42 IF WVSTART=0
SET WVSTART=$PIECE(WVDATE,".")
if WVSTART=0
QUIT
+43 SET WVEDD("OLD")=WVEDD
SET WVEDD=+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2)
+44 IF WVEDD>0
SET WVEDD=+$$FMADD^XLFDT(WVEDD,$$GETGRACD)
+45 IF WVEDD=0
SET WVEDD=+$$FMADD^XLFDT(WVSTART,(280+$$GETGRACD))
+46 IF WVSTART=WVSTART("OLD")
Begin DoDot:4
+47 IF WVEDD=WVEDD("OLD")
KILL WVINDEX(WVSTART,WVEDD)
SET WVIEN("START")=WVIEN
+48 IF WVEDD'=WVEDD("OLD")
KILL WVINDEX(WVSTART,WVEDD("OLD"))
End DoDot:4
+49 IF WVSTART'=WVSTART("OLD")
Begin DoDot:4
+50 IF WVSTART<WVEDD("OLD")
Begin DoDot:5
+51 KILL WVINDEX(WVSTART("OLD"),WVEDD("OLD"))
+52 SET WVEDD("OLD")=+$$FMADD^XLFDT(WVSTART,-1)
+53 SET WVINDEX(WVSTART("OLD"),WVEDD("OLD"),WVIEN("START"))=""
+54 SET WVIEN("START")=WVIEN
End DoDot:5
+55 IF WVSTART=WVEDD("OLD")
SET WVIEN("CONT-START")=WVIEN
End DoDot:4
+56 KILL WVSTART("OLD"),WVEDD("OLD")
+57 IF $GET(WVIEN("CONT-START"))>0
QUIT
+58 SET WVINDEX(WVSTART,WVEDD,WVIEN)=""
End DoDot:3
+59 IF WVSTART=0
Begin DoDot:3
+60 SET WVSTART=+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U)
+61 IF WVSTART=0
SET WVSTART=$PIECE(WVDATE,".")
+62 SET WVEDD=+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2)
SET WVIEN("START")=WVIEN
+63 IF (WVEND>0)!($GET(WVEND("GUESS"))>0)
Begin DoDot:4
+64 IF WVEND=0
SET WVEND=WVEND("GUESS")
+65 SET WVSTART("INDEX")=$$FMADD^XLFDT(WVSTART,-1)
+66 IF WVSTART("INDEX")>=WVEND
SET WVINDEX(WVEND,WVSTART("INDEX"),$SELECT(+$GET(WVIEN("CONT-END"))>0:WVIEN("CONT-END"),1:WVIEN("END")))=""
+67 SET WVEND=0
+68 KILL WVIEN("END"),WVSTART("INDEX"),WVIEN("CONT-END"),WVEND("GUESS")
End DoDot:4
+69 IF WVEDD>0
Begin DoDot:4
+70 SET WVEDD=+$$FMADD^XLFDT(WVEDD,$$GETGRACD)
+71 SET WVINDEX(WVSTART,WVEDD,WVIEN)=""
End DoDot:4
+72 IF WVEDD=0
Begin DoDot:4
+73 SET WVEDD=+$$FMADD^XLFDT(WVSTART,(280+$$GETGRACD))
+74 SET WVINDEX(WVSTART,WVEDD,WVIEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+75 IF $GET(WVEND("GUESS"))>0
SET WVEND=WVEND("GUESS")
+76 IF WVEND>0
Begin DoDot:1
+77 SET WVINDEX(WVEND,$SELECT(WVEND<DT:DT,1:WVEND),$SELECT($DATA(WVIEN("CONT-END"))=1:WVIEN("CONT-END"),1:WVIEN("END")))=""
End DoDot:1
+78 IF WVCDE
IF $GET(WVSTATUS)=1
IF DT>WVEDD
Begin DoDot:1
+79 KILL WVINDEX(WVSTART,WVEDD)
+80 SET WVEDD=+$$FMADD^XLFDT(DT,1)
+81 SET WVINDEX(WVSTART,WVEDD,WVIEN("START"))=""
End DoDot:1
+82 IF WVSAVE
Begin DoDot:1
+83 KILL ^WV(790,WVDFN,WVNODE,"APREG")
+84 IF $DATA(WVINDEX)
MERGE ^WV(790,WVDFN,WVNODE,"APREG")=WVINDEX
End DoDot:1
+85 QUIT
GETGRACD() ;WRAPPER TO CALL GETGRACD^PXRMCWH1
+1 ;PXRM*2.0*45 INSTALLS AFTER WV*1.0*24
+2 ;REMOVE THIS LINE-TAG IF PATCHING THIS ROUTINE AFTER WV*1.0*24
+3 IF $TEXT(GETGRACD^PXRMCWH1)
QUIT $$GETGRACD^PXRMCWH1
+4 QUIT 28
LACTS(WVDFN,WVINDEX,WVCDE) ;CREATES INDEX OF LACTATION STATUSES
+1 ; INPUT: WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
+2 ; WVINDEX - REFERENCE TO ARRAY IN WHICH TO RETURN THE INDEX OF STATUSES
+3 ; WVCDE - CALCULATE END DATE; FOR LACTATIONS THAT DO NOT HAVE A SPECIFIED
+4 ; END DATE BUT HAVE A "NO LONGER LACTATING" STATUS FOLLOWING IT,
+5 ; WVCDE=1 WILL SET THAT LACTATION'S END DATE TO TOMORROW
+6 ; AND WVCDE=0 WILL SET THAT LACTATION'S END DATE TO THE
+7 ; "NO LONGER LACTATING" STATUS' D/T ENTERED. WVCDE=1 IS USED
+8 ; BY DIALOGS TO PROMPT FOR END OF LACTATION DATA
+9 ; OUTPUT: WVINDEX(START,STOP,STOP_IEN)=""
+10 NEW WVDATE,WVIEN,WVSTART,WVEND,WVSAVE,WVNODE,WVSTATUS
+11 SET WVCDE=+$GET(WVCDE)
+12 SET WVSAVE=$SELECT(WVCDE=0:1,1:0)
SET (WVSTART,WVEND)=0
SET WVNODE=5
+13 SET WVDATE=""
FOR
SET WVDATE=$ORDER(^WV(790,WVDFN,WVNODE,"B",WVDATE))
if WVDATE=""
QUIT
SET WVIEN=""
FOR
SET WVIEN=$ORDER(^WV(790,WVDFN,WVNODE,"B",WVDATE,WVIEN))
if WVIEN=""
QUIT
Begin DoDot:1
+14 if $PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,0)),U,6)=1
QUIT
+15 SET WVSTATUS=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U)
+16 IF WVSTATUS=1
Begin DoDot:2
+17 IF WVSTART>0
Begin DoDot:3
+18 IF $DATA(WVEND("GUESS"))
SET WVSTART=0
QUIT
+19 SET WVIEN("CONT-START")=WVIEN
End DoDot:3
+20 IF WVSTART=0
Begin DoDot:3
+21 SET WVSTART=$PIECE(WVDATE,".")
SET WVIEN("START")=WVIEN
+22 IF (WVEND>0)!($GET(WVEND("GUESS"))>0)
Begin DoDot:4
+23 IF WVEND=0
SET WVEND=+$$FMADD^XLFDT(WVEND("GUESS"),1)
+24 SET WVSTART("INDEX")=$$FMADD^XLFDT(WVSTART,-1)
+25 IF WVSTART("INDEX")>=WVEND
SET WVINDEX(WVEND,WVSTART("INDEX"),$SELECT(+$GET(WVIEN("CONT-END"))>0:WVIEN("CONT-END"),1:WVIEN("END")))=""
+26 SET WVEND=0
+27 KILL WVEND("GUESS"),WVIEN("END"),WVSTART("INDEX"),WVIEN("CONT-END")
End DoDot:4
End DoDot:3
End DoDot:2
+28 IF WVSTATUS=0
Begin DoDot:2
+29 IF WVEND>0
SET WVIEN("CONT-END")=WVIEN
IF '$DATA(WVEND("GUESS"))
QUIT
+30 SET WVEND=+$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,2)
SET WVIEN("END")=WVIEN
+31 IF WVEND>0
Begin DoDot:3
+32 IF $GET(WVEND("GUESS"))>0
KILL WVINDEX(WVSTART,WVEND("GUESS")),WVEND("GUESS")
+33 IF WVSTART=0
Begin DoDot:4
+34 SET WVINDEX(1410102,WVEND,WVIEN)=""
End DoDot:4
+35 IF WVSTART>0
Begin DoDot:4
+36 SET WVINDEX(WVSTART,WVEND,$SELECT(+$GET(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))=""
SET WVSTART=0
KILL WVIEN("START"),WVIEN("CONT-START")
End DoDot:4
+37 SET WVEND=$$FMADD^XLFDT(WVEND,1)
End DoDot:3
QUIT
+38 IF WVEND=0
Begin DoDot:3
+39 IF WVSTART=0
SET WVEND=$PIECE($PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,0)),U),".")
+40 IF WVSTART>0
Begin DoDot:4
+41 if $GET(WVEND("GUESS"))>0
QUIT
+42 SET WVEND("GUESS")=$SELECT(WVCDE:+$$FMADD^XLFDT(DT,1),1:+$$FMADD^XLFDT($PIECE(WVDATE,"."),-1))
+43 IF WVSTART<=WVEND("GUESS")
SET WVINDEX(WVSTART,WVEND("GUESS"),$SELECT(+$GET(WVIEN("CONT-START"))>0:WVIEN("CONT-START"),1:WVIEN("START")))=""
KILL WVIEN("CONT-START")
+44 IF WVSTART>WVEND("GUESS")
SET WVSTART=0
SET WVEND("GUESS")=$SELECT(WVCDE:DT,1:$PIECE($PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,0)),U),"."))
KILL WVIEN("START")
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+45 IF $GET(WVEND("GUESS"))>0
SET WVEND=+$$FMADD^XLFDT(WVEND("GUESS"),1)
+46 IF WVEND>0
Begin DoDot:1
+47 SET WVINDEX(WVEND,$SELECT(WVEND<DT:DT,1:WVEND),$SELECT($DATA(WVIEN("CONT-END"))=1:WVIEN("CONT-END"),1:WVIEN("END")))=""
End DoDot:1
+48 IF WVSTART>0
IF WVEND=0
SET WVINDEX(WVSTART,DT,$SELECT($DATA(WVIEN("CONT-START"))=1:WVIEN("CONT-START"),1:WVIEN("START")))=""
+49 IF WVSAVE
Begin DoDot:1
+50 KILL ^WV(790,WVDFN,WVNODE,"ALACT")
+51 IF $DATA(WVINDEX)
MERGE ^WV(790,WVDFN,WVNODE,"ALACT")=WVINDEX
End DoDot:1
+52 QUIT
MOA(WVMOA,WVDFN,WVDT) ;RETURN LIKELIHOOD OF BECOMING PREGNANT
+1 ; GIVEN THE METHOD OF CONTRACEPTION
+2 ; INPUT: WVMOA - CONTRACEPTIVE METHOD (NAME OR IEN IN FILE #791)
+3 ; WVDFN - PATIENT IEN IN WV PATIENT FILE (#790)
+4 ; WVDATE - DATE TO USE WHEN CALCULATING THE LIKELIHOOD
+5 ; OUTPUT: 1 - HIGH, 2 - LOW, -1 - Error
+6 if $GET(WVMOA)=""
QUIT -1
+7 NEW WVIEN,WVRETURN
+8 SET WVRETURN=-1
SET WVDT=$GET(WVDT,DT)
SET WVDT=$PIECE(WVDT,".")
+9 SET WVIEN=$SELECT(WVMOA'=+WVMOA:$ORDER(^WV(791,"B",WVMOA,0)),1:WVMOA)
+10 if 'WVIEN
QUIT WVRETURN
+11 IF $DATA(^WV(791,WVIEN,1))
XECUTE ^WV(791,WVIEN,1)
+12 IF '$TEST
SET WVRETURN=$PIECE($GET(^WV(791,WVIEN,0)),U,2)
+13 if WVRETURN<1
SET WVRETURN=-1
+14 QUIT WVRETURN
GETLREC(WVDFN,WVNODE) ;RETURN "IEN^DATE^ENTERED BY^STATUS" OF MOST RECENT PREGNANCY
+1 ; OR LACTATION STATUS RECORD
+2 NEW WVRET,WVSTATUS,WVIEN
+3 SET WVRET=0
+4 SET WVSTATUS=$$ISIT^WVUTL11(WVNODE,WVDFN,DT,"",0,1)
+5 SET WVIEN=+$PIECE(WVSTATUS,U,2)
SET WVSTATUS=$PIECE(WVSTATUS,U)
+6 IF WVIEN>0
Begin DoDot:1
+7 IF 'WVSTATUS
IF WVNODE=4
IF $PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U)=2
Begin DoDot:2
+8 SET WVSTATUS=2
End DoDot:2
+9 SET WVRET=WVIEN_U_$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,0)),U,1,2)_U_WVSTATUS
End DoDot:1
+10 QUIT WVRET
REM(WVDFN,WVNAME,WVFIEVAL) ;EVALUATE REMINDER DEFINITION
+1 ;RETURN: $$REM => EVAL STATUS
+2 NEW WVPARAMS,WVRESULT,WVREMST
+3 SET WVFIEVAL=+$GET(WVFIEVAL)
+4 SET WVPARAMS("SUB")="WV APPLICABLE"
SET WVPARAMS("DFN")=WVDFN
+5 SET WVPARAMS("REMINDERS",WVNAME)=WVFIEVAL_U_5
+6 DO EN^PXRMGEV(.WVRESULT,.WVPARAMS)
+7 IF $PIECE($GET(^TMP($JOB,"WV APPLICABLE",0)),U)=-1
QUIT ^TMP($JOB,"WV APPLICABLE",0)
+8 SET WVREMST=$PIECE($GET(^TMP($JOB,"WV APPLICABLE",WVNAME)),U)
+9 if 'WVFIEVAL
KILL ^TMP($JOB,"WV APPLICABLE")
+10 IF WVREMST=""
QUIT -1_U_"Reminder "_WVNAME_" evaluation did not return a status."
+11 QUIT WVREMST
