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

WVRPCOR.m

Go to the documentation of this file.
WVRPCOR ;ISP/RFR - CPRS RPCS ;Mar 24, 2020@15:18
 ;;1.0;WOMEN'S HEALTH;**24**;Sep 30, 1998;Build 582
 Q
COVER(WVRETURN,WVDFN) ;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)) 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(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=$S($P(WVAPPL,U,2)="DUE NOW":0,1:$$GETLREC(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)) S WVSTATUS=WVEXTERNAL(WVSTATUS)
 .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(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
 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(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
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
POSTSHRT(WVDFN) ;RETURN POSTING LETTERS
 N WVSUB,WVLETTER,WVRET
 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 WVRET=$G(WVRET)_WVLETTER
 Q $G(WVRET)
POSTLIST(WVRETURN,WVDFN,WVLINE) ;RETURN LIST OF POSTINGS
 N WVSUB,WVLETTER,WVRECID
 I '$D(WVLINE) S WVLINE=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(WVLINE)="WH"_U_$P($P(^XTMP(WVSUB,WVRECID,"CS PANEL"),U),":")_U_WVLETTER,WVLINE=WVLINE+1
 Q
POSTREP(WVRETURN,WVDFN,WVTYPE) ;RETURN POSTINGS REPORT
 ;RPC: WVRPCOR POSTREP
 N WVSUB,WVRECID,WVSUBST,WVTEXT
 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_#
 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
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