Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: WVUTL11

WVUTL11.m

Go to the documentation of this file.
WVUTL11 ;ISP/RFR - TERATOGENIC DRUGS UTILITY FUNCTIONS;May 22, 2018@14:18
 ;;1.0;WOMEN'S HEALTH;**24**;Sep 30, 1998;Build 582
 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(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 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 WVSTATUS'=1 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=$$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 $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
GETORDRS(WVDFN,WVLAC) ;Entry point for retrieving harmful orders
 ; INPUT: WVLAC - 1 to indicate calling context is lactation
 ;                0 (default) to indicate calling context is not lactation
 ; OUTPUT: $$GETORDRS - Global node address where orders are stored
 S WVDFN=+$G(WVDFN),WVLAC=+$G(WVLAC)
 Q:WVDFN<1 ""
 N INPUT,WVRETURN,WVORN,WVORDCHK
 S INPUT("SUB")="WVDATA",INPUT("DFN")=WVDFN
 S INPUT("ROC","ALL")=""
 S INPUT("ROC DISPLAY GROUPS","PHARMACY")="",INPUT("ROC DISPLAY GROUPS","IMAGING")=""
 S INPUT("ROC DISPLAY GROUPS","IMAGING","START")=$$GET^XPAR("ALL","WV IMAGING ORDER START DT",1,"I")
 S INPUT("ROC DISPLAY GROUPS","IMAGING","STOP")=DT
 S INPUT("ROC STATUS","HOLD")=""
 S INPUT("ROC STATUS","PENDING")=""
 S INPUT("ROC STATUS","SCHEDULED")=""
 S INPUT("ROC STATUS","ACTIVE")=""
 S INPUT("ROC RETURN TYPE","RULES")="",INPUT("ROC RETURN TYPE","OI")=""
 D EN^PXRMGEV(.WVRETURN,.INPUT)
 S WVORN=0 F  S WVORN=$O(^TMP($J,"WVDATA",WVORN)) Q:'+WVORN  D
 .S WVORDCHK=0 F  S WVORDCHK=$O(^TMP($J,"WVDATA",WVORN,"RULES",WVORDCHK)) Q:WVORDCHK=""  D
 ..I $E(WVORDCHK,1,13)'="VA-WH HIRISK " K ^TMP($J,"WVDATA",WVORN,"RULES",WVORDCHK) Q 
 ..I WVLAC&(WVORDCHK'["IMAGING") D
 ...N WVOIN,WVAGENT,WVPKG
 ...S WVOIN=0 F  S WVOIN=$O(^TMP($J,"WVDATA",WVORN,"OI",WVOIN)) Q:'+WVOIN!($G(WVAGENT))  D
 ....S WVPKG=$P($G(^TMP($J,"WVDATA",WVORN,"OI",WVOIN)),U,2) Q:WVPKG'["PSP"
 ....S WVAGENT=$$IMGAGNT(+WVPKG)
 ...S ^TMP($J,"WVDATA",WVORN,"IMGAGNT")=+$G(WVAGENT)
 .I '$D(^TMP($J,"WVDATA",WVORN,"RULES")) K ^TMP($J,"WVDATA",WVORN)
 I $O(^TMP($J,"WVDATA",0))="" S ^TMP($J,"WVDATA",0)=0
 Q $G(WVRETURN)
IMGAGNT(WVOIIEN) ;Return true if the orderable item resolves to an imaging agent
 ;INPUT: WVOIIEN - IEN of entry in PHARMACY ORDERABLE ITEM file (#50.7)
 S WVOIIEN=+$G(WVOIIEN)
 Q:WVOIIEN<1 -1
 N WVDIENS,WVDIEN,WVRET,WVGNAME
 S WVGNAME="VA-WH HIRISK IMAGING AGENTS GROUP"
 D ITEMLIST^PXRMAPI("",WVGNAME,"A","WVROCDATA")
 D DRGIEN^PSS50P7(WVOIIEN,DT,"WVDRUGS")
 I $G(^TMP($J,"WVDRUGS",0))>0 M WVDIENS=^TMP($J,"WVDRUGS") K WVDIENS(0)
 K ^TMP($J,"WVDRUGS")
 S WVDIEN=0 F  S WVDIEN=$O(WVDIENS(WVDIEN)) Q:'+WVDIEN!($G(WVRET))  D
 .I $D(^TMP($J,"WVROCDATA",WVGNAME,"P",WVDIEN_";PS(50,")) S WVRET=1 Q  ;DRUG IEN
 .D DATA^PSS50(WVDIEN,,,,,"WVDRUG")
 .I $D(^TMP($J,"WVROCDATA",WVGNAME,"P",$P($G(^TMP($J,"WVDRUG",WVDIEN,25)),U)_";PS(50.605,")) S WVRET=1 ;VA CLASSIFICATION
 .I $D(^TMP($J,"WVROCDATA",WVGNAME,"P",$P($G(^TMP($J,"WVDRUG",WVDIEN,20)),U)_";PSNDF(50.6,")) S WVRET=1 ;VA GENERIC
 .I $D(^TMP($J,"WVROCDATA",WVGNAME,"P",$P($G(^TMP($J,"WVDRUG",WVDIEN,22)),U)_";PSNDF(60.58,")) S WVRET=1 ;VA PRODUCT
 .K ^TMP($J,"WVDRUG")
 K ^TMP($J,"WVROCDATA")
 Q +$G(WVRET)