WVRPCOR ;ISP/RFR - CPRS RPCS ; Oct 26, 2023@11:43
;;1.0;WOMEN'S HEALTH;**24,26,30**;Sep 30, 1998;Build 5
;
; Reference to WRAP^ORUTL in ICR #6263
Q
COVER(WVRETURN,WVDFN,WVFCLR) ;RETURN DATA FOR COVER SHEET PANEL
;RPC: WVRPCOR COVER
N WVSUB,WVRECID,WVLINE
I $G(WVDFN)'?1.N S WVRETURN(0)=-1_U_"Invalid patient identifier: WVDFN="_$G(WVDFN) Q
S WVSUB=$$GETSUB(WVDFN)
I ('$D(^XTMP(WVSUB)))!($G(WVFCLR)=1) D GETCOVER(WVDFN,WVSUB)
I $G(^XTMP(WVSUB,"ERROR"))'="" S WVRETURN(0)=-1_U_$TR(^XTMP(WVSUB,"ERROR"),".") Q
S WVRETURN(0)=1_U
S WVRECID=0 F S WVRECID=$O(^XTMP(WVSUB,WVRECID)) Q:WVRECID=""!(WVRECID'[";") D
.S WVLINE=1+$G(WVLINE),WVRETURN(WVLINE)=WVRECID_U_^XTMP(WVSUB,WVRECID,"CS PANEL")
.I $P(WVRECID,";")=0 S $P(WVRETURN(0),U)=0
Q
DETAIL(WVRETURN,WVRECID) ;RETURN DATA FOR COVER SHEET PANEL DETAILS
;RPC: WVRPCOR DETAIL
N WVSUB,WVLINE,WVLINES,WVIEN
S WVSUB=$$GETSUB($P(WVRECID,",",2))
I '$D(^XTMP(WVSUB,WVRECID)) D GETCOVER($P(WVRECID,",",2),WVSUB)
S WVLINES=0,WVIEN=$P($P(WVRECID,";",2),",")
F WVLINE=1:1 Q:'$D(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)) D
.D WRAP^ORUTL($G(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)),"WVRETURN",$S(WVIEN=0:0,1:1),1,,.WVLINES,60)
Q
GETCOVER(WVDFN,WVSUB) ;GET DATA NEEDED FOR COVER SHEET
N WVTYPES,WVEXTERNAL,WVBLOCK,WVRECID,WVNODE,WVERROR,WVREASONS
D SETUP
K ^XTMP(WVSUB)
S ^XTMP(WVSUB,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"DATA FOR CPRS COVER SHEET"
S WVBLOCK=$$BLOCK(.WVREASONS,WVDFN)
I +WVBLOCK=-1 D Q
.S ^XTMP(WVSUB,"ERROR")="Could not determine applicability; "_$P(WVBLOCK,U,2)
I +WVBLOCK D Q
.S WVRECID="0;0,"_WVDFN_","
.S ^XTMP(WVSUB,WVRECID,"CS PANEL")="Not"_U_"Applicable"
.M ^XTMP(WVSUB,WVRECID,"CS DETAIL")=WVREASONS
S WVNODE=0 F S WVNODE=$O(WVTYPES(WVNODE)) Q:'+WVNODE!($D(WVERROR)) D
.N WVFOUND,WVSTATUS,WVTITLE,WVEDD,WVEND,WVMETHODS,WVIEN,WVAPPL,WVNOTES
.N WVNOTE,WVREASON,WVWANT,WVLINE,WVPNUM
.S WVAPPL=$$APPL(WVDFN,WVNODE),WVLINE=1
.I +WVAPPL=-1 D Q
..S WVERROR="Could not determine applicability; "_$P(WVAPPL,U,2)
.I '+WVAPPL D
..S WVSTATUS=$S(WVNODE=WVTYPES("B","P"):"Unable to Conceive",WVNODE=WVTYPES("B","L"):"Not Applicable",1:"")
..I $P(WVAPPL,U,2)["Medically unable to conceive" S WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
..I ($P(WVAPPL,U,2)'["Medically unable to conceive")!($P($G(WVFOUND),U)=0) D
...S WVRECID=WVNODE_";0,"_WVDFN_",",WVREASON=$P(WVAPPL,U,2)
...F WVPNUM=1:1:$L(WVREASON,"<BR>") D
....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$P(WVREASON,"<BR>",WVPNUM),WVLINE=WVLINE+1
.I +WVAPPL D
..S WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
..I '+WVFOUND D
...S WVRECID=WVNODE_";0,"_WVDFN_","
...S WVSTATUS="No data available"
...S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="No data on file.",WVLINE=WVLINE+1
.I +$G(WVFOUND) D
..S WVIEN=$P(WVFOUND,U)
..S:'$D(WVSTATUS) WVSTATUS=$P(WVFOUND,U,4)
..S WVRECID=WVNODE_";"_WVIEN_","_WVDFN_","
..I WVNODE=WVTYPES("B","P") D
...I WVSTATUS=1 D
....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Last Menstrual Period: "_$$FMTE^XLFDT($P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U),"1M"),WVLINE=WVLINE+1
....S WVEDD=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2),WVEDD("TEXT")="Expected Due Date"_$S(WVEDD="":"*",1:"")
....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$$RJ^XLFSTR(WVEDD("TEXT"),21)_": "_$$FMTE^XLFDT(WVEDD,"1M"),WVLINE=WVLINE+1
...I WVSTATUS="Unable to Conceive" D
....Q:$P($G(^WV(790,WVDFN,4,WVIEN,2)),U,2)'=1
....S WVREASON=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,3)
....I WVREASON'="" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Reason: "_WVREASON,WVLINE=WVLINE+1
...I WVSTATUS'=1 D
....S WVEND=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4)
....I WVEND'="" D
.....I WVSTATUS="Unable to Conceive" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="",WVLINE=WVLINE+1
.....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Previous pregnancy:",WVLINE=WVLINE+1
.....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Ended: "_$$FMTE^XLFDT(WVEND,"1M"),WVLINE=WVLINE+1
.....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Reason: "_$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,5),WVLINE=WVLINE+1
....S WVWANT=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,4)
....I WVWANT'="" D
.....I WVEND'="" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="",WVLINE=WVLINE+1
.....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Does"_$S('WVWANT:" not",1:"")_" want to become pregnant within the next year.",WVLINE=WVLINE+1
....D GETS^DIQ(790.05,WVIEN_","_WVDFN_",","30*","","WVMETHODS","WVERROR")
....Q:$D(WVERROR)
....S WVMETHODS="" F S WVMETHODS=$O(WVMETHODS(790.17,WVMETHODS)) Q:WVMETHODS="" D
.....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$S(+WVMETHODS=1:"Contraceptive Methods: ",1:" ")_WVMETHODS(790.17,WVMETHODS,.01),WVLINE=WVLINE+1
..I WVNODE=WVTYPES("B","L") D
...I WVSTATUS=0 D
....S WVEND=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,2) Q:WVEND=""
....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Ended: "_$$FMTE^XLFDT(WVEND,"1M"),WVLINE=WVLINE+1
..S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="",WVLINE=WVLINE+1
..I $P(WVFOUND,U,3)'="" D
...S WVTITLE=$$GET1^DIQ(200,$P(WVFOUND,U,3),8)
...S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Entered by: "_$$GET1^DIQ(200,$P(WVFOUND,U,3),.01)_$S(WVTITLE'="":" ("_WVTITLE_")",1:""),WVLINE=WVLINE+1
..I $P(WVFOUND,U,2)'="" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Entered on: "_$$FMTE^XLFDT($P(WVFOUND,U,2),"1M"),WVLINE=WVLINE+1
.I $D(WVNOTES) D
..F WVNOTE=1:1:WVNOTES S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=WVNOTES(WVNOTE),WVLINE=WVLINE+1
..K WVNOTES
.I WVSTATUS=1 S ^XTMP(WVSUB,"POSTINGS",$E($P(WVTYPES(WVNODE),U,3),1))=WVRECID
.I $D(WVEXTERNAL(WVSTATUS)) D
..S WVSTATUS=WVEXTERNAL(WVSTATUS)_$S($P(WVAPPL,U,2)="DUE NOW":" - Reminder Due ("_$P(WVTYPES(WVNODE),U,6)_")",1:"")
.I WVSTATUS="" S WVSTATUS="Unknown"
.S ^XTMP(WVSUB,WVRECID,"CS PANEL")=$P(WVTYPES(WVNODE),U,3)_U_WVSTATUS
I $D(WVERROR) S ^XTMP(WVSUB,"ERROR")=WVERROR
Q
APPL(WVDFN,WVNODE) ;DETERMINE IF DATA TYPE IS APPLICABLE TO PATIENT
N WVREMST,WVSTATUS,WVREMDEF,WVLINE,WVEXIT,WVTEXT,WVEDDGRA,WVFNUM,WVDOCST
N WVGLOBAL,WVCAPTUR,WVRETURN,WVDELIM,WVCNT,WVRTL,WVSTATDT
S (WVCAPTUR,WVEXIT,WVRTL)=0,WVDELIM="<BR>"
S WVREMDEF=$P(WVTYPES(WVNODE),U),WVFNUM=$P(WVTYPES(WVNODE),U,5)
S WVREMST=$$REM^WVUTL11(WVDFN,WVREMDEF,1)
S WVSTATUS=$S(WVREMST="N/A":0,+WVREMST=-1:WVREMST,1:1)
I WVREMST="N/A"!(WVREMST="DUE NOW") D
.I WVNODE=WVTYPES("B","P") D
..I $G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",1))=1 D
...S WVGLOBAL=$NA(^TMP($J,"WV APPLICABLE",WVREMDEF,"FINDINGS","Medically Unable to Conceive ID","MAINTENANCE"))
...I WVREMST="DUE NOW" S WVSTATUS=0
.I $G(WVGLOBAL)="" S WVGLOBAL=$NA(^TMP($J,"WV APPLICABLE",WVREMDEF,"MAINTENANCE"))
.S WVLINE=0 F S WVLINE=$O(@WVGLOBAL@(WVLINE)) Q:('+WVLINE)!(WVEXIT) D
..S WVTEXT=$G(@WVGLOBAL@(WVLINE))
..I (WVTEXT["Frequency:")!(WVTEXT["Computed Finding") S WVCAPTUR=1 Q
..I WVTEXT["Cohort:" S WVCAPTUR=2,WVDELIM="<BR>" Q
..I WVTEXT["Reminder Term: " S WVRTL=WVLINE Q
..I WVTEXT["Prov. Narr. -" S WVDELIM="<BR>"
..I '+WVCAPTUR Q
..I +WVCAPTUR=1,WVTEXT="" S WVEXIT=1 Q
..I +WVCAPTUR=2 D Q:WVEXIT
...I WVTEXT="" S WVCNT=1+$G(WVCNT) I WVCNT>1 S WVEXIT=1 Q
...I WVTEXT'="" S WVCNT=0
..S WVRETURN=$S($G(WVRETURN)'="":WVRETURN_WVDELIM,1:"")_$$TRIM^XLFSTR(WVTEXT)
..I +WVCAPTUR=2,WVRTL>0,WVLINE>(WVRTL+1) S WVDELIM=" ",WVRTL=0
.S $P(WVSTATUS,U,2)=$G(WVRETURN)
I WVREMST="DUE NOW" D
.S WVEXIT=0,WVDOCST=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"DOCUMENTATION STATUS"))
.S WVSTATDT=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"DATE"))
.I WVDOCST="COMPLETE",WVNODE=4 D Q:WVEXIT
..S WVEDDGRA=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"EDD-GRACE"))
..I WVEDDGRA>0,WVEDDGRA>=DT S WVEXIT=1
.I WVDOCST="INCOMPLETE",WVSTATDT>$P(($$FMADD^XLFDT(DT,-365,-8)),".",1) Q ;INCOMPLETE LESS THAN 1 YEAR OLD
.S $P(WVSTATUS,U,2)=WVREMST
S $P(WVTYPES(WVNODE),U,6)=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"PRINT NAME"))
K ^TMP($J,"WV APPLICABLE")
Q WVSTATUS
BLOCK(WVREASONS,WVDFN) ;DETERMINE WHETHER TO BLOCK DATA ENTRY FOR SPECIFICED TYPE
N WVSTATUS,WVCAPTUR,WVLINE,WVTEXT,WVRETURN,WVREMDEF
S WVREMDEF="VA-WH PREGNANCY AND LACTATION DATA ENTRY ALLOWED",WVSTATUS=$$REM^WVUTL11(WVDFN,WVREMDEF,1)
S WVCAPTUR=0,WVRETURN=0_U,WVREASONS=0
I WVSTATUS="N/A" D
.S WVLINE=0 F S WVLINE=$O(^TMP($J,"WV APPLICABLE",WVREMDEF,"MAINTENANCE",WVLINE)) Q:'+WVLINE D
..S WVTEXT=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"MAINTENANCE",WVLINE))
..I WVTEXT["Cohort:" S WVCAPTUR=1,WVRETURN=1_U Q
..I ('WVCAPTUR)!(WVTEXT["Computed Finding")!(WVTEXT[" value - ")!(WVTEXT="") Q
..S WVREASONS=WVREASONS+1,WVREASONS(WVREASONS)=$$TRIM^XLFSTR(WVTEXT)
I +WVSTATUS=-1 S WVRETURN=WVSTATUS
K ^TMP($J,"WV APPLICABLE")
Q WVRETURN
POSTSHRT(WVDFN) ;RETURN POSTING LETTERS
N WVSUB,WVLETTER,WVRET,WVPOSTINGS
S WVSUB=$$GETSUB(WVDFN)
I $D(^XTMP(WVSUB)) M WVPOSTINGS=^XTMP(WVSUB,"POSTINGS")
E D
.N WVTYPES,WVEXTERNAL,WVNODE,WVFOUND,WVIEN,WVRECID
.D SETUP
.S WVNODE=0 F S WVNODE=$O(WVTYPES(WVNODE)) Q:'+WVNODE D
..S WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
..I $P(WVFOUND,U,4)=1 D
...S WVIEN=$P(WVFOUND,U),WVRECID=WVNODE_";"_WVIEN_","_WVDFN_","
...S WVPOSTINGS($E($P(WVTYPES(WVNODE),U,3),1))=WVRECID
S WVLETTER="" F S WVLETTER=$O(WVPOSTINGS(WVLETTER)) Q:WVLETTER="" D
.S WVRET=$G(WVRET)_WVLETTER
Q $G(WVRET)
POSTLIST(WVRETURN,WVDFN,WVITEM) ;RETURN LIST OF POSTINGS
N WVSUB,WVLETTER,WVRECID
I +$G(WVITEM)=0 S WVITEM=1+$O(WVRETURN("?"),-1)
S WVSUB=$$GETSUB(WVDFN)
I '$D(^XTMP(WVSUB)) D GETCOVER(WVDFN,WVSUB)
S WVLETTER="" F S WVLETTER=$O(^XTMP(WVSUB,"POSTINGS",WVLETTER)) Q:WVLETTER="" D
.S WVRECID=^XTMP(WVSUB,"POSTINGS",WVLETTER)
.S WVRETURN(WVITEM)="WH"_U_$P($P(^XTMP(WVSUB,WVRECID,"CS PANEL"),U),":")_U_WVLETTER,WVITEM=WVITEM+1
Q
POSTREP(WVRETURN,WVDFN,WVTYPE) ;RETURN POSTINGS REPORT
;RPC: WVRPCOR POSTREP
N WVSUB,WVRECID,WVSUBST,WVTEXT,WVLINE,WVLINES
S WVDFN=$G(WVDFN),WVTYPE=$G(WVTYPE)
I WVDFN'?1.N S WVRETURN=1,WVRETURN(1)="Invalid patient identifier: WVDFN="_$G(WVDFN) Q
I WVTYPE'?1U S WVRETURN=1,WVRETURN(1)="Invalid report type specified: '"_WVTYPE_"'." Q
S WVSUBST(U)=" ",WVSUB=$$GETSUB(WVDFN)
I '$D(^XTMP(WVSUB)) D GETCOVER(WVDFN,WVSUB)
S WVRECID=$G(^XTMP(WVSUB,"POSTINGS",WVTYPE))
I WVRECID="" S WVRETURN=1,WVRETURN(1)="No Women's Health postings available." Q
S WVLINES=0,WVTEXT=$$REPLACE^XLFSTR($G(^XTMP(WVSUB,WVRECID,"CS PANEL")),.WVSUBST)
S WVTEXT=$$RJ^XLFSTR($P(WVTEXT,":"),21)_":"_$P(WVTEXT,":",2)
D WRAP^ORUTL(WVTEXT,"WVRETURN",,,,.WVLINES,60)
F WVLINE=1:1 Q:'$D(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)) D WRAP^ORUTL($G(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)),"WVRETURN",,,,.WVLINES,60)
Q
SETUP ;INITIALIZE ARRAY THAT MAPS DATA AND REMINDERS
;WVTYPES(790_GLOBAL_NODE_#)=DATA_REMINDER_NAME^FILE_#^DISPLAY_LABEL^STATUS DISPLAY^FIEVAL_#^DATA_REMINDER_PRINT_NAME
S WVTYPES(4)="VA-WH UPDATE PREGNANCY STATUS^790.05^Pregnant:^Pregnancy^3^"
S WVTYPES(5)="VA-WH UPDATE LACTATION STATUS^790.16^Lactating:^Lactation^2^"
S WVTYPES("B","P")=4,WVTYPES("B","L")=5
S WVEXTERNAL(1)="Yes",WVEXTERNAL(0)="No",WVEXTERNAL(-1)="Not Applicable",WVEXTERNAL(2)="Do not know"
Q
GETSUB(WVDFN) ;RETURN ^XTMP CACHE SUBSCRIPT
Q "WV_CCS;"_WVDFN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPCOR 11313 printed Sep 23, 2025@20:24 Page 2
WVRPCOR ;ISP/RFR - CPRS RPCS ; Oct 26, 2023@11:43
+1 ;;1.0;WOMEN'S HEALTH;**24,26,30**;Sep 30, 1998;Build 5
+2 ;
+3 ; Reference to WRAP^ORUTL in ICR #6263
+4 QUIT
COVER(WVRETURN,WVDFN,WVFCLR) ;RETURN DATA FOR COVER SHEET PANEL
+1 ;RPC: WVRPCOR COVER
+2 NEW WVSUB,WVRECID,WVLINE
+3 IF $GET(WVDFN)'?1.N
SET WVRETURN(0)=-1_U_"Invalid patient identifier: WVDFN="_$GET(WVDFN)
QUIT
+4 SET WVSUB=$$GETSUB(WVDFN)
+5 IF ('$DATA(^XTMP(WVSUB)))!($GET(WVFCLR)=1)
DO GETCOVER(WVDFN,WVSUB)
+6 IF $GET(^XTMP(WVSUB,"ERROR"))'=""
SET WVRETURN(0)=-1_U_$TRANSLATE(^XTMP(WVSUB,"ERROR"),".")
QUIT
+7 SET WVRETURN(0)=1_U
+8 SET WVRECID=0
FOR
SET WVRECID=$ORDER(^XTMP(WVSUB,WVRECID))
if WVRECID=""!(WVRECID'[";")
QUIT
Begin DoDot:1
+9 SET WVLINE=1+$GET(WVLINE)
SET WVRETURN(WVLINE)=WVRECID_U_^XTMP(WVSUB,WVRECID,"CS PANEL")
+10 IF $PIECE(WVRECID,";")=0
SET $PIECE(WVRETURN(0),U)=0
End DoDot:1
+11 QUIT
DETAIL(WVRETURN,WVRECID) ;RETURN DATA FOR COVER SHEET PANEL DETAILS
+1 ;RPC: WVRPCOR DETAIL
+2 NEW WVSUB,WVLINE,WVLINES,WVIEN
+3 SET WVSUB=$$GETSUB($PIECE(WVRECID,",",2))
+4 IF '$DATA(^XTMP(WVSUB,WVRECID))
DO GETCOVER($PIECE(WVRECID,",",2),WVSUB)
+5 SET WVLINES=0
SET WVIEN=$PIECE($PIECE(WVRECID,";",2),",")
+6 FOR WVLINE=1:1
if '$DATA(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE))
QUIT
Begin DoDot:1
+7 DO WRAP^ORUTL($GET(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)),"WVRETURN",$SELECT(WVIEN=0:0,1:1),1,,.WVLINES,60)
End DoDot:1
+8 QUIT
GETCOVER(WVDFN,WVSUB) ;GET DATA NEEDED FOR COVER SHEET
+1 NEW WVTYPES,WVEXTERNAL,WVBLOCK,WVRECID,WVNODE,WVERROR,WVREASONS
+2 DO SETUP
+3 KILL ^XTMP(WVSUB)
+4 SET ^XTMP(WVSUB,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"DATA FOR CPRS COVER SHEET"
+5 SET WVBLOCK=$$BLOCK(.WVREASONS,WVDFN)
+6 IF +WVBLOCK=-1
Begin DoDot:1
+7 SET ^XTMP(WVSUB,"ERROR")="Could not determine applicability; "_$PIECE(WVBLOCK,U,2)
End DoDot:1
QUIT
+8 IF +WVBLOCK
Begin DoDot:1
+9 SET WVRECID="0;0,"_WVDFN_","
+10 SET ^XTMP(WVSUB,WVRECID,"CS PANEL")="Not"_U_"Applicable"
+11 MERGE ^XTMP(WVSUB,WVRECID,"CS DETAIL")=WVREASONS
End DoDot:1
QUIT
+12 SET WVNODE=0
FOR
SET WVNODE=$ORDER(WVTYPES(WVNODE))
if '+WVNODE!($DATA(WVERROR))
QUIT
Begin DoDot:1
+13 NEW WVFOUND,WVSTATUS,WVTITLE,WVEDD,WVEND,WVMETHODS,WVIEN,WVAPPL,WVNOTES
+14 NEW WVNOTE,WVREASON,WVWANT,WVLINE,WVPNUM
+15 SET WVAPPL=$$APPL(WVDFN,WVNODE)
SET WVLINE=1
+16 IF +WVAPPL=-1
Begin DoDot:2
+17 SET WVERROR="Could not determine applicability; "_$PIECE(WVAPPL,U,2)
End DoDot:2
QUIT
+18 IF '+WVAPPL
Begin DoDot:2
+19 SET WVSTATUS=$SELECT(WVNODE=WVTYPES("B","P"):"Unable to Conceive",WVNODE=WVTYPES("B","L"):"Not Applicable",1:"")
+20 IF $PIECE(WVAPPL,U,2)["Medically unable to conceive"
SET WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
+21 IF ($PIECE(WVAPPL,U,2)'["Medically unable to conceive")!($PIECE($GET(WVFOUND),U)=0)
Begin DoDot:3
+22 SET WVRECID=WVNODE_";0,"_WVDFN_","
SET WVREASON=$PIECE(WVAPPL,U,2)
+23 FOR WVPNUM=1:1:$LENGTH(WVREASON,"<BR>")
Begin DoDot:4
+24 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$PIECE(WVREASON,"<BR>",WVPNUM)
SET WVLINE=WVLINE+1
End DoDot:4
End DoDot:3
End DoDot:2
+25 IF +WVAPPL
Begin DoDot:2
+26 SET WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
+27 IF '+WVFOUND
Begin DoDot:3
+28 SET WVRECID=WVNODE_";0,"_WVDFN_","
+29 SET WVSTATUS="No data available"
+30 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="No data on file."
SET WVLINE=WVLINE+1
End DoDot:3
End DoDot:2
+31 IF +$GET(WVFOUND)
Begin DoDot:2
+32 SET WVIEN=$PIECE(WVFOUND,U)
+33 if '$DATA(WVSTATUS)
SET WVSTATUS=$PIECE(WVFOUND,U,4)
+34 SET WVRECID=WVNODE_";"_WVIEN_","_WVDFN_","
+35 IF WVNODE=WVTYPES("B","P")
Begin DoDot:3
+36 IF WVSTATUS=1
Begin DoDot:4
+37 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Last Menstrual Period: "_$$FMTE^XLFDT($PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U),"1M")
SET WVLINE=WVLINE+1
+38 SET WVEDD=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2)
SET WVEDD("TEXT")="Expected Due Date"_$SELECT(WVEDD="":"*",1:"")
+39 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$$RJ^XLFSTR(WVEDD("TEXT"),21)_": "_$$FMTE^XLFDT(WVEDD,"1M")
SET WVLINE=WVLINE+1
End DoDot:4
+40 IF WVSTATUS="Unable to Conceive"
Begin DoDot:4
+41 if $PIECE($GET(^WV(790,WVDFN,4,WVIEN,2)),U,2)'=1
QUIT
+42 SET WVREASON=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,3)
+43 IF WVREASON'=""
SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Reason: "_WVREASON
SET WVLINE=WVLINE+1
End DoDot:4
+44 IF WVSTATUS'=1
Begin DoDot:4
+45 SET WVEND=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4)
+46 IF WVEND'=""
Begin DoDot:5
+47 IF WVSTATUS="Unable to Conceive"
SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=""
SET WVLINE=WVLINE+1
+48 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Previous pregnancy:"
SET WVLINE=WVLINE+1
+49 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Ended: "_$$FMTE^XLFDT(WVEND,"1M")
SET WVLINE=WVLINE+1
+50 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Reason: "_$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,5)
SET WVLINE=WVLINE+1
End DoDot:5
+51 SET WVWANT=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,4)
+52 IF WVWANT'=""
Begin DoDot:5
+53 IF WVEND'=""
SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=""
SET WVLINE=WVLINE+1
+54 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Does"_$SELECT('WVWANT:" not",1:"")_" want to become pregnant within the next year."
SET WVLINE=WVLINE+1
End DoDot:5
+55 DO GETS^DIQ(790.05,WVIEN_","_WVDFN_",","30*","","WVMETHODS","WVERROR")
+56 if $DATA(WVERROR)
QUIT
+57 SET WVMETHODS=""
FOR
SET WVMETHODS=$ORDER(WVMETHODS(790.17,WVMETHODS))
if WVMETHODS=""
QUIT
Begin DoDot:5
+58 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$SELECT(+WVMETHODS=1:"Contraceptive Methods: ",1:" ")_WVMETHODS(790.17,WVMETHODS,.01)
SET WVLINE=WVLINE+1
End DoDot:5
End DoDot:4
End DoDot:3
+59 IF WVNODE=WVTYPES("B","L")
Begin DoDot:3
+60 IF WVSTATUS=0
Begin DoDot:4
+61 SET WVEND=$PIECE($GET(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,2)
if WVEND=""
QUIT
+62 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=" Ended: "_$$FMTE^XLFDT(WVEND,"1M")
SET WVLINE=WVLINE+1
End DoDot:4
End DoDot:3
+63 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=""
SET WVLINE=WVLINE+1
+64 IF $PIECE(WVFOUND,U,3)'=""
Begin DoDot:3
+65 SET WVTITLE=$$GET1^DIQ(200,$PIECE(WVFOUND,U,3),8)
+66 SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Entered by: "_$$GET1^DIQ(200,$PIECE(WVFOUND,U,3),.01)_$SELECT(WVTITLE'="":" ("_WVTITLE_")",1:"")
SET WVLINE=WVLINE+1
End DoDot:3
+67 IF $PIECE(WVFOUND,U,2)'=""
SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Entered on: "_$$FMTE^XLFDT($PIECE(WVFOUND,U,2),"1M")
SET WVLINE=WVLINE+1
End DoDot:2
+68 IF $DATA(WVNOTES)
Begin DoDot:2
+69 FOR WVNOTE=1:1:WVNOTES
SET ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=WVNOTES(WVNOTE)
SET WVLINE=WVLINE+1
+70 KILL WVNOTES
End DoDot:2
+71 IF WVSTATUS=1
SET ^XTMP(WVSUB,"POSTINGS",$EXTRACT($PIECE(WVTYPES(WVNODE),U,3),1))=WVRECID
+72 IF $DATA(WVEXTERNAL(WVSTATUS))
Begin DoDot:2
+73 SET WVSTATUS=WVEXTERNAL(WVSTATUS)_$SELECT($PIECE(WVAPPL,U,2)="DUE NOW":" - Reminder Due ("_$PIECE(WVTYPES(WVNODE),U,6)_")",1:"")
End DoDot:2
+74 IF WVSTATUS=""
SET WVSTATUS="Unknown"
+75 SET ^XTMP(WVSUB,WVRECID,"CS PANEL")=$PIECE(WVTYPES(WVNODE),U,3)_U_WVSTATUS
End DoDot:1
+76 IF $DATA(WVERROR)
SET ^XTMP(WVSUB,"ERROR")=WVERROR
+77 QUIT
APPL(WVDFN,WVNODE) ;DETERMINE IF DATA TYPE IS APPLICABLE TO PATIENT
+1 NEW WVREMST,WVSTATUS,WVREMDEF,WVLINE,WVEXIT,WVTEXT,WVEDDGRA,WVFNUM,WVDOCST
+2 NEW WVGLOBAL,WVCAPTUR,WVRETURN,WVDELIM,WVCNT,WVRTL,WVSTATDT
+3 SET (WVCAPTUR,WVEXIT,WVRTL)=0
SET WVDELIM="<BR>"
+4 SET WVREMDEF=$PIECE(WVTYPES(WVNODE),U)
SET WVFNUM=$PIECE(WVTYPES(WVNODE),U,5)
+5 SET WVREMST=$$REM^WVUTL11(WVDFN,WVREMDEF,1)
+6 SET WVSTATUS=$SELECT(WVREMST="N/A":0,+WVREMST=-1:WVREMST,1:1)
+7 IF WVREMST="N/A"!(WVREMST="DUE NOW")
Begin DoDot:1
+8 IF WVNODE=WVTYPES("B","P")
Begin DoDot:2
+9 IF $GET(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"FIEVAL",1))=1
Begin DoDot:3
+10 SET WVGLOBAL=$NAME(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"FINDINGS","Medically Unable to Conceive ID","MAINTENANCE"))
+11 IF WVREMST="DUE NOW"
SET WVSTATUS=0
End DoDot:3
End DoDot:2
+12 IF $GET(WVGLOBAL)=""
SET WVGLOBAL=$NAME(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"MAINTENANCE"))
+13 SET WVLINE=0
FOR
SET WVLINE=$ORDER(@WVGLOBAL@(WVLINE))
if ('+WVLINE)!(WVEXIT)
QUIT
Begin DoDot:2
+14 SET WVTEXT=$GET(@WVGLOBAL@(WVLINE))
+15 IF (WVTEXT["Frequency:")!(WVTEXT["Computed Finding")
SET WVCAPTUR=1
QUIT
+16 IF WVTEXT["Cohort:"
SET WVCAPTUR=2
SET WVDELIM="<BR>"
QUIT
+17 IF WVTEXT["Reminder Term: "
SET WVRTL=WVLINE
QUIT
+18 IF WVTEXT["Prov. Narr. -"
SET WVDELIM="<BR>"
+19 IF '+WVCAPTUR
QUIT
+20 IF +WVCAPTUR=1
IF WVTEXT=""
SET WVEXIT=1
QUIT
+21 IF +WVCAPTUR=2
Begin DoDot:3
+22 IF WVTEXT=""
SET WVCNT=1+$GET(WVCNT)
IF WVCNT>1
SET WVEXIT=1
QUIT
+23 IF WVTEXT'=""
SET WVCNT=0
End DoDot:3
if WVEXIT
QUIT
+24 SET WVRETURN=$SELECT($GET(WVRETURN)'="":WVRETURN_WVDELIM,1:"")_$$TRIM^XLFSTR(WVTEXT)
+25 IF +WVCAPTUR=2
IF WVRTL>0
IF WVLINE>(WVRTL+1)
SET WVDELIM=" "
SET WVRTL=0
End DoDot:2
+26 SET $PIECE(WVSTATUS,U,2)=$GET(WVRETURN)
End DoDot:1
+27 IF WVREMST="DUE NOW"
Begin DoDot:1
+28 SET WVEXIT=0
SET WVDOCST=$GET(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"DOCUMENTATION STATUS"))
+29 SET WVSTATDT=$GET(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"DATE"))
+30 IF WVDOCST="COMPLETE"
IF WVNODE=4
Begin DoDot:2
+31 SET WVEDDGRA=$GET(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"EDD-GRACE"))
+32 IF WVEDDGRA>0
IF WVEDDGRA>=DT
SET WVEXIT=1
End DoDot:2
if WVEXIT
QUIT
+33 ;INCOMPLETE LESS THAN 1 YEAR OLD
IF WVDOCST="INCOMPLETE"
IF WVSTATDT>$PIECE(($$FMADD^XLFDT(DT,-365,-8)),".",1)
QUIT
+34 SET $PIECE(WVSTATUS,U,2)=WVREMST
End DoDot:1
+35 SET $PIECE(WVTYPES(WVNODE),U,6)=$GET(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"PRINT NAME"))
+36 KILL ^TMP($JOB,"WV APPLICABLE")
+37 QUIT WVSTATUS
BLOCK(WVREASONS,WVDFN) ;DETERMINE WHETHER TO BLOCK DATA ENTRY FOR SPECIFICED TYPE
+1 NEW WVSTATUS,WVCAPTUR,WVLINE,WVTEXT,WVRETURN,WVREMDEF
+2 SET WVREMDEF="VA-WH PREGNANCY AND LACTATION DATA ENTRY ALLOWED"
SET WVSTATUS=$$REM^WVUTL11(WVDFN,WVREMDEF,1)
+3 SET WVCAPTUR=0
SET WVRETURN=0_U
SET WVREASONS=0
+4 IF WVSTATUS="N/A"
Begin DoDot:1
+5 SET WVLINE=0
FOR
SET WVLINE=$ORDER(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"MAINTENANCE",WVLINE))
if '+WVLINE
QUIT
Begin DoDot:2
+6 SET WVTEXT=$GET(^TMP($JOB,"WV APPLICABLE",WVREMDEF,"MAINTENANCE",WVLINE))
+7 IF WVTEXT["Cohort:"
SET WVCAPTUR=1
SET WVRETURN=1_U
QUIT
+8 IF ('WVCAPTUR)!(WVTEXT["Computed Finding")!(WVTEXT[" value - ")!(WVTEXT="")
QUIT
+9 SET WVREASONS=WVREASONS+1
SET WVREASONS(WVREASONS)=$$TRIM^XLFSTR(WVTEXT)
End DoDot:2
End DoDot:1
+10 IF +WVSTATUS=-1
SET WVRETURN=WVSTATUS
+11 KILL ^TMP($JOB,"WV APPLICABLE")
+12 QUIT WVRETURN
POSTSHRT(WVDFN) ;RETURN POSTING LETTERS
+1 NEW WVSUB,WVLETTER,WVRET,WVPOSTINGS
+2 SET WVSUB=$$GETSUB(WVDFN)
+3 IF $DATA(^XTMP(WVSUB))
MERGE WVPOSTINGS=^XTMP(WVSUB,"POSTINGS")
+4 IF '$TEST
Begin DoDot:1
+5 NEW WVTYPES,WVEXTERNAL,WVNODE,WVFOUND,WVIEN,WVRECID
+6 DO SETUP
+7 SET WVNODE=0
FOR
SET WVNODE=$ORDER(WVTYPES(WVNODE))
if '+WVNODE
QUIT
Begin DoDot:2
+8 SET WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
+9 IF $PIECE(WVFOUND,U,4)=1
Begin DoDot:3
+10 SET WVIEN=$PIECE(WVFOUND,U)
SET WVRECID=WVNODE_";"_WVIEN_","_WVDFN_","
+11 SET WVPOSTINGS($EXTRACT($PIECE(WVTYPES(WVNODE),U,3),1))=WVRECID
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET WVLETTER=""
FOR
SET WVLETTER=$ORDER(WVPOSTINGS(WVLETTER))
if WVLETTER=""
QUIT
Begin DoDot:1
+13 SET WVRET=$GET(WVRET)_WVLETTER
End DoDot:1
+14 QUIT $GET(WVRET)
POSTLIST(WVRETURN,WVDFN,WVITEM) ;RETURN LIST OF POSTINGS
+1 NEW WVSUB,WVLETTER,WVRECID
+2 IF +$GET(WVITEM)=0
SET WVITEM=1+$ORDER(WVRETURN("?"),-1)
+3 SET WVSUB=$$GETSUB(WVDFN)
+4 IF '$DATA(^XTMP(WVSUB))
DO GETCOVER(WVDFN,WVSUB)
+5 SET WVLETTER=""
FOR
SET WVLETTER=$ORDER(^XTMP(WVSUB,"POSTINGS",WVLETTER))
if WVLETTER=""
QUIT
Begin DoDot:1
+6 SET WVRECID=^XTMP(WVSUB,"POSTINGS",WVLETTER)
+7 SET WVRETURN(WVITEM)="WH"_U_$PIECE($PIECE(^XTMP(WVSUB,WVRECID,"CS PANEL"),U),":")_U_WVLETTER
SET WVITEM=WVITEM+1
End DoDot:1
+8 QUIT
POSTREP(WVRETURN,WVDFN,WVTYPE) ;RETURN POSTINGS REPORT
+1 ;RPC: WVRPCOR POSTREP
+2 NEW WVSUB,WVRECID,WVSUBST,WVTEXT,WVLINE,WVLINES
+3 SET WVDFN=$GET(WVDFN)
SET WVTYPE=$GET(WVTYPE)
+4 IF WVDFN'?1.N
SET WVRETURN=1
SET WVRETURN(1)="Invalid patient identifier: WVDFN="_$GET(WVDFN)
QUIT
+5 IF WVTYPE'?1U
SET WVRETURN=1
SET WVRETURN(1)="Invalid report type specified: '"_WVTYPE_"'."
QUIT
+6 SET WVSUBST(U)=" "
SET WVSUB=$$GETSUB(WVDFN)
+7 IF '$DATA(^XTMP(WVSUB))
DO GETCOVER(WVDFN,WVSUB)
+8 SET WVRECID=$GET(^XTMP(WVSUB,"POSTINGS",WVTYPE))
+9 IF WVRECID=""
SET WVRETURN=1
SET WVRETURN(1)="No Women's Health postings available."
QUIT
+10 SET WVLINES=0
SET WVTEXT=$$REPLACE^XLFSTR($GET(^XTMP(WVSUB,WVRECID,"CS PANEL")),.WVSUBST)
+11 SET WVTEXT=$$RJ^XLFSTR($PIECE(WVTEXT,":"),21)_":"_$PIECE(WVTEXT,":",2)
+12 DO WRAP^ORUTL(WVTEXT,"WVRETURN",,,,.WVLINES,60)
+13 FOR WVLINE=1:1
if '$DATA(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE))
QUIT
DO WRAP^ORUTL($GET(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)),"WVRETURN",,,,.WVLINES,60)
+14 QUIT
SETUP ;INITIALIZE ARRAY THAT MAPS DATA AND REMINDERS
+1 ;WVTYPES(790_GLOBAL_NODE_#)=DATA_REMINDER_NAME^FILE_#^DISPLAY_LABEL^STATUS DISPLAY^FIEVAL_#^DATA_REMINDER_PRINT_NAME
+2 SET WVTYPES(4)="VA-WH UPDATE PREGNANCY STATUS^790.05^Pregnant:^Pregnancy^3^"
+3 SET WVTYPES(5)="VA-WH UPDATE LACTATION STATUS^790.16^Lactating:^Lactation^2^"
+4 SET WVTYPES("B","P")=4
SET WVTYPES("B","L")=5
+5 SET WVEXTERNAL(1)="Yes"
SET WVEXTERNAL(0)="No"
SET WVEXTERNAL(-1)="Not Applicable"
SET WVEXTERNAL(2)="Do not know"
+6 QUIT
GETSUB(WVDFN) ;RETURN ^XTMP CACHE SUBSCRIPT
+1 QUIT "WV_CCS;"_WVDFN
