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. 
  1. WVRPCOR ;ISP/RFR - CPRS RPCS ; Oct 26, 2023@11:43
  1.  ;;1.0;WOMEN'S HEALTH;**24,26,30**;Sep 30, 1998;Build 5
  1.  ;
  1.  ; Reference to WRAP^ORUTL in ICR #6263
  1.  Q
  1. COVER(WVRETURN,WVDFN,WVFCLR) ;RETURN DATA FOR COVER SHEET PANEL
  1.  ;RPC: WVRPCOR COVER
  1.  N WVSUB,WVRECID,WVLINE
  1.  I $G(WVDFN)'?1.N S WVRETURN(0)=-1_U_"Invalid patient identifier: WVDFN="_$G(WVDFN) Q
  1.  S WVSUB=$$GETSUB(WVDFN)
  1.  I ('$D(^XTMP(WVSUB)))!($G(WVFCLR)=1) D GETCOVER(WVDFN,WVSUB)
  1.  I $G(^XTMP(WVSUB,"ERROR"))'="" S WVRETURN(0)=-1_U_$TR(^XTMP(WVSUB,"ERROR"),".") Q
  1.  S WVRETURN(0)=1_U
  1.  S WVRECID=0 F  S WVRECID=$O(^XTMP(WVSUB,WVRECID)) Q:WVRECID=""!(WVRECID'[";")  D
  1.  .S WVLINE=1+$G(WVLINE),WVRETURN(WVLINE)=WVRECID_U_^XTMP(WVSUB,WVRECID,"CS PANEL")
  1.  .I $P(WVRECID,";")=0 S $P(WVRETURN(0),U)=0
  1.  Q
  1. DETAIL(WVRETURN,WVRECID) ;RETURN DATA FOR COVER SHEET PANEL DETAILS
  1.  ;RPC: WVRPCOR DETAIL
  1.  N WVSUB,WVLINE,WVLINES,WVIEN
  1.  S WVSUB=$$GETSUB($P(WVRECID,",",2))
  1.  I '$D(^XTMP(WVSUB,WVRECID)) D GETCOVER($P(WVRECID,",",2),WVSUB)
  1.  S WVLINES=0,WVIEN=$P($P(WVRECID,";",2),",")
  1.  F WVLINE=1:1 Q:'$D(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE))  D
  1.  .D WRAP^ORUTL($G(^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)),"WVRETURN",$S(WVIEN=0:0,1:1),1,,.WVLINES,60)
  1.  Q
  1. GETCOVER(WVDFN,WVSUB) ;GET DATA NEEDED FOR COVER SHEET
  1.  N WVTYPES,WVEXTERNAL,WVBLOCK,WVRECID,WVNODE,WVERROR,WVREASONS
  1.  D SETUP
  1.  K ^XTMP(WVSUB)
  1.  S ^XTMP(WVSUB,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"DATA FOR CPRS COVER SHEET"
  1.  S WVBLOCK=$$BLOCK(.WVREASONS,WVDFN)
  1.  I +WVBLOCK=-1 D  Q
  1.  .S ^XTMP(WVSUB,"ERROR")="Could not determine applicability; "_$P(WVBLOCK,U,2)
  1.  I +WVBLOCK D  Q
  1.  .S WVRECID="0;0,"_WVDFN_","
  1.  .S ^XTMP(WVSUB,WVRECID,"CS PANEL")="Not"_U_"Applicable"
  1.  .M ^XTMP(WVSUB,WVRECID,"CS DETAIL")=WVREASONS
  1.  S WVNODE=0 F  S WVNODE=$O(WVTYPES(WVNODE)) Q:'+WVNODE!($D(WVERROR))  D
  1.  .N WVFOUND,WVSTATUS,WVTITLE,WVEDD,WVEND,WVMETHODS,WVIEN,WVAPPL,WVNOTES
  1.  .N WVNOTE,WVREASON,WVWANT,WVLINE,WVPNUM
  1.  .S WVAPPL=$$APPL(WVDFN,WVNODE),WVLINE=1
  1.  .I +WVAPPL=-1 D  Q
  1.  ..S WVERROR="Could not determine applicability; "_$P(WVAPPL,U,2)
  1.  .I '+WVAPPL D
  1.  ..S WVSTATUS=$S(WVNODE=WVTYPES("B","P"):"Unable to Conceive",WVNODE=WVTYPES("B","L"):"Not Applicable",1:"")
  1.  ..I $P(WVAPPL,U,2)["Medically unable to conceive" S WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
  1.  ..I ($P(WVAPPL,U,2)'["Medically unable to conceive")!($P($G(WVFOUND),U)=0) D
  1.  ...S WVRECID=WVNODE_";0,"_WVDFN_",",WVREASON=$P(WVAPPL,U,2)
  1.  ...F WVPNUM=1:1:$L(WVREASON,"<BR>")  D
  1.  ....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$P(WVREASON,"<BR>",WVPNUM),WVLINE=WVLINE+1
  1.  .I +WVAPPL D
  1.  ..S WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
  1.  ..I '+WVFOUND D
  1.  ...S WVRECID=WVNODE_";0,"_WVDFN_","
  1.  ...S WVSTATUS="No data available"
  1.  ...S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="No data on file.",WVLINE=WVLINE+1
  1.  .I +$G(WVFOUND) D
  1.  ..S WVIEN=$P(WVFOUND,U)
  1.  ..S:'$D(WVSTATUS) WVSTATUS=$P(WVFOUND,U,4)
  1.  ..S WVRECID=WVNODE_";"_WVIEN_","_WVDFN_","
  1.  ..I WVNODE=WVTYPES("B","P") D
  1.  ...I WVSTATUS=1 D
  1.  ....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
  1.  ....S WVEDD=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,2),WVEDD("TEXT")="Expected Due Date"_$S(WVEDD="":"*",1:"")
  1.  ....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$$RJ^XLFSTR(WVEDD("TEXT"),21)_": "_$$FMTE^XLFDT(WVEDD,"1M"),WVLINE=WVLINE+1
  1.  ...I WVSTATUS="Unable to Conceive" D
  1.  ....Q:$P($G(^WV(790,WVDFN,4,WVIEN,2)),U,2)'=1
  1.  ....S WVREASON=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,3)
  1.  ....I WVREASON'="" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="               Reason: "_WVREASON,WVLINE=WVLINE+1
  1.  ...I WVSTATUS'=1 D
  1.  ....S WVEND=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,4)
  1.  ....I WVEND'="" D
  1.  .....I WVSTATUS="Unable to Conceive" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="",WVLINE=WVLINE+1
  1.  .....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Previous pregnancy:",WVLINE=WVLINE+1
  1.  .....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="                Ended: "_$$FMTE^XLFDT(WVEND,"1M"),WVLINE=WVLINE+1
  1.  .....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="               Reason: "_$P($G(^WV(790,WVDFN,WVNODE,WVIEN,4)),U,5),WVLINE=WVLINE+1
  1.  ....S WVWANT=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,4)
  1.  ....I WVWANT'="" D
  1.  .....I WVEND'="" S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="",WVLINE=WVLINE+1
  1.  .....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Does"_$S('WVWANT:" not",1:"")_" want to become pregnant within the next year.",WVLINE=WVLINE+1
  1.  ....D GETS^DIQ(790.05,WVIEN_","_WVDFN_",","30*","","WVMETHODS","WVERROR")
  1.  ....Q:$D(WVERROR)
  1.  ....S WVMETHODS="" F  S WVMETHODS=$O(WVMETHODS(790.17,WVMETHODS)) Q:WVMETHODS=""  D
  1.  .....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=$S(+WVMETHODS=1:"Contraceptive Methods: ",1:"                       ")_WVMETHODS(790.17,WVMETHODS,.01),WVLINE=WVLINE+1
  1.  ..I WVNODE=WVTYPES("B","L") D
  1.  ...I WVSTATUS=0 D
  1.  ....S WVEND=$P($G(^WV(790,WVDFN,WVNODE,WVIEN,2)),U,2) Q:WVEND=""
  1.  ....S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="       Ended: "_$$FMTE^XLFDT(WVEND,"1M"),WVLINE=WVLINE+1
  1.  ..S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="",WVLINE=WVLINE+1
  1.  ..I $P(WVFOUND,U,3)'="" D
  1.  ...S WVTITLE=$$GET1^DIQ(200,$P(WVFOUND,U,3),8)
  1.  ...S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)="Entered by: "_$$GET1^DIQ(200,$P(WVFOUND,U,3),.01)_$S(WVTITLE'="":" ("_WVTITLE_")",1:""),WVLINE=WVLINE+1
  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
  1.  .I $D(WVNOTES) D
  1.  ..F WVNOTE=1:1:WVNOTES  S ^XTMP(WVSUB,WVRECID,"CS DETAIL",WVLINE)=WVNOTES(WVNOTE),WVLINE=WVLINE+1
  1.  ..K WVNOTES
  1.  .I WVSTATUS=1 S ^XTMP(WVSUB,"POSTINGS",$E($P(WVTYPES(WVNODE),U,3),1))=WVRECID
  1.  .I $D(WVEXTERNAL(WVSTATUS)) D
  1.  ..S WVSTATUS=WVEXTERNAL(WVSTATUS)_$S($P(WVAPPL,U,2)="DUE NOW":" - Reminder Due ("_$P(WVTYPES(WVNODE),U,6)_")",1:"")
  1.  .I WVSTATUS="" S WVSTATUS="Unknown"
  1.  .S ^XTMP(WVSUB,WVRECID,"CS PANEL")=$P(WVTYPES(WVNODE),U,3)_U_WVSTATUS
  1.  I $D(WVERROR) S ^XTMP(WVSUB,"ERROR")=WVERROR
  1.  Q
  1. APPL(WVDFN,WVNODE) ;DETERMINE IF DATA TYPE IS APPLICABLE TO PATIENT
  1.  N WVREMST,WVSTATUS,WVREMDEF,WVLINE,WVEXIT,WVTEXT,WVEDDGRA,WVFNUM,WVDOCST
  1.  N WVGLOBAL,WVCAPTUR,WVRETURN,WVDELIM,WVCNT,WVRTL,WVSTATDT
  1.  S (WVCAPTUR,WVEXIT,WVRTL)=0,WVDELIM="<BR>"
  1.  S WVREMDEF=$P(WVTYPES(WVNODE),U),WVFNUM=$P(WVTYPES(WVNODE),U,5)
  1.  S WVREMST=$$REM^WVUTL11(WVDFN,WVREMDEF,1)
  1.  S WVSTATUS=$S(WVREMST="N/A":0,+WVREMST=-1:WVREMST,1:1)
  1.  I WVREMST="N/A"!(WVREMST="DUE NOW") D
  1.  .I WVNODE=WVTYPES("B","P") D
  1.  ..I $G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",1))=1 D
  1.  ...S WVGLOBAL=$NA(^TMP($J,"WV APPLICABLE",WVREMDEF,"FINDINGS","Medically Unable to Conceive ID","MAINTENANCE"))
  1.  ...I WVREMST="DUE NOW" S WVSTATUS=0
  1.  .I $G(WVGLOBAL)="" S WVGLOBAL=$NA(^TMP($J,"WV APPLICABLE",WVREMDEF,"MAINTENANCE"))
  1.  .S WVLINE=0 F  S WVLINE=$O(@WVGLOBAL@(WVLINE)) Q:('+WVLINE)!(WVEXIT)  D
  1.  ..S WVTEXT=$G(@WVGLOBAL@(WVLINE))
  1.  ..I (WVTEXT["Frequency:")!(WVTEXT["Computed Finding") S WVCAPTUR=1 Q
  1.  ..I WVTEXT["Cohort:" S WVCAPTUR=2,WVDELIM="<BR>" Q
  1.  ..I WVTEXT["Reminder Term: " S WVRTL=WVLINE Q
  1.  ..I WVTEXT["Prov. Narr. -" S WVDELIM="<BR>"
  1.  ..I '+WVCAPTUR Q
  1.  ..I +WVCAPTUR=1,WVTEXT="" S WVEXIT=1 Q
  1.  ..I +WVCAPTUR=2 D  Q:WVEXIT
  1.  ...I WVTEXT="" S WVCNT=1+$G(WVCNT) I WVCNT>1 S WVEXIT=1 Q
  1.  ...I WVTEXT'="" S WVCNT=0
  1.  ..S WVRETURN=$S($G(WVRETURN)'="":WVRETURN_WVDELIM,1:"")_$$TRIM^XLFSTR(WVTEXT)
  1.  ..I +WVCAPTUR=2,WVRTL>0,WVLINE>(WVRTL+1) S WVDELIM=" ",WVRTL=0
  1.  .S $P(WVSTATUS,U,2)=$G(WVRETURN)
  1.  I WVREMST="DUE NOW" D
  1.  .S WVEXIT=0,WVDOCST=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"DOCUMENTATION STATUS"))
  1.  .S WVSTATDT=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"DATE"))
  1.  .I WVDOCST="COMPLETE",WVNODE=4 D  Q:WVEXIT
  1.  ..S WVEDDGRA=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"FIEVAL",WVFNUM,"EDD-GRACE"))
  1.  ..I WVEDDGRA>0,WVEDDGRA>=DT S WVEXIT=1
  1.  .I WVDOCST="INCOMPLETE",WVSTATDT>$P(($$FMADD^XLFDT(DT,-365,-8)),".",1) Q  ;INCOMPLETE LESS THAN 1 YEAR OLD
  1.  .S $P(WVSTATUS,U,2)=WVREMST
  1.  S $P(WVTYPES(WVNODE),U,6)=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"PRINT NAME"))
  1.  K ^TMP($J,"WV APPLICABLE")
  1.  Q WVSTATUS
  1. BLOCK(WVREASONS,WVDFN) ;DETERMINE WHETHER TO BLOCK DATA ENTRY FOR SPECIFICED TYPE
  1.  N WVSTATUS,WVCAPTUR,WVLINE,WVTEXT,WVRETURN,WVREMDEF
  1.  S WVREMDEF="VA-WH PREGNANCY AND LACTATION DATA ENTRY ALLOWED",WVSTATUS=$$REM^WVUTL11(WVDFN,WVREMDEF,1)
  1.  S WVCAPTUR=0,WVRETURN=0_U,WVREASONS=0
  1.  I WVSTATUS="N/A" D
  1.  .S WVLINE=0 F  S WVLINE=$O(^TMP($J,"WV APPLICABLE",WVREMDEF,"MAINTENANCE",WVLINE)) Q:'+WVLINE  D
  1.  ..S WVTEXT=$G(^TMP($J,"WV APPLICABLE",WVREMDEF,"MAINTENANCE",WVLINE))
  1.  ..I WVTEXT["Cohort:" S WVCAPTUR=1,WVRETURN=1_U Q
  1.  ..I ('WVCAPTUR)!(WVTEXT["Computed Finding")!(WVTEXT[" value - ")!(WVTEXT="") Q
  1.  ..S WVREASONS=WVREASONS+1,WVREASONS(WVREASONS)=$$TRIM^XLFSTR(WVTEXT)
  1.  I +WVSTATUS=-1 S WVRETURN=WVSTATUS
  1.  K ^TMP($J,"WV APPLICABLE")
  1.  Q WVRETURN
  1. POSTSHRT(WVDFN) ;RETURN POSTING LETTERS
  1.  N WVSUB,WVLETTER,WVRET,WVPOSTINGS
  1.  S WVSUB=$$GETSUB(WVDFN)
  1.  I $D(^XTMP(WVSUB)) M WVPOSTINGS=^XTMP(WVSUB,"POSTINGS")
  1.  E  D
  1.  .N WVTYPES,WVEXTERNAL,WVNODE,WVFOUND,WVIEN,WVRECID
  1.  .D SETUP
  1.  .S WVNODE=0 F  S WVNODE=$O(WVTYPES(WVNODE)) Q:'+WVNODE  D
  1.  ..S WVFOUND=$$GETLREC^WVUTL11(WVDFN,WVNODE)
  1.  ..I $P(WVFOUND,U,4)=1 D
  1.  ...S WVIEN=$P(WVFOUND,U),WVRECID=WVNODE_";"_WVIEN_","_WVDFN_","
  1.  ...S WVPOSTINGS($E($P(WVTYPES(WVNODE),U,3),1))=WVRECID
  1.  S WVLETTER="" F  S WVLETTER=$O(WVPOSTINGS(WVLETTER)) Q:WVLETTER=""  D
  1.  .S WVRET=$G(WVRET)_WVLETTER
  1.  Q $G(WVRET)
  1. POSTLIST(WVRETURN,WVDFN,WVITEM) ;RETURN LIST OF POSTINGS
  1.  N WVSUB,WVLETTER,WVRECID
  1.  I +$G(WVITEM)=0 S WVITEM=1+$O(WVRETURN("?"),-1)
  1.  S WVSUB=$$GETSUB(WVDFN)
  1.  I '$D(^XTMP(WVSUB)) D GETCOVER(WVDFN,WVSUB)
  1.  S WVLETTER="" F  S WVLETTER=$O(^XTMP(WVSUB,"POSTINGS",WVLETTER)) Q:WVLETTER=""  D
  1.  .S WVRECID=^XTMP(WVSUB,"POSTINGS",WVLETTER)
  1.  .S WVRETURN(WVITEM)="WH"_U_$P($P(^XTMP(WVSUB,WVRECID,"CS PANEL"),U),":")_U_WVLETTER,WVITEM=WVITEM+1
  1.  Q
  1. POSTREP(WVRETURN,WVDFN,WVTYPE) ;RETURN POSTINGS REPORT
  1.  ;RPC: WVRPCOR POSTREP
  1.  N WVSUB,WVRECID,WVSUBST,WVTEXT,WVLINE,WVLINES
  1.  S WVDFN=$G(WVDFN),WVTYPE=$G(WVTYPE)
  1.  I WVDFN'?1.N S WVRETURN=1,WVRETURN(1)="Invalid patient identifier: WVDFN="_$G(WVDFN) Q
  1.  I WVTYPE'?1U S WVRETURN=1,WVRETURN(1)="Invalid report type specified: '"_WVTYPE_"'." Q
  1.  S WVSUBST(U)=" ",WVSUB=$$GETSUB(WVDFN)
  1.  I '$D(^XTMP(WVSUB)) D GETCOVER(WVDFN,WVSUB)
  1.  S WVRECID=$G(^XTMP(WVSUB,"POSTINGS",WVTYPE))
  1.  I WVRECID="" S WVRETURN=1,WVRETURN(1)="No Women's Health postings available." Q
  1.  S WVLINES=0,WVTEXT=$$REPLACE^XLFSTR($G(^XTMP(WVSUB,WVRECID,"CS PANEL")),.WVSUBST)
  1.  S WVTEXT=$$RJ^XLFSTR($P(WVTEXT,":"),21)_":"_$P(WVTEXT,":",2)
  1.  D WRAP^ORUTL(WVTEXT,"WVRETURN",,,,.WVLINES,60)
  1.  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)
  1.  Q
  1. 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
  1.  S WVTYPES(4)="VA-WH UPDATE PREGNANCY STATUS^790.05^Pregnant:^Pregnancy^3^"
  1.  S WVTYPES(5)="VA-WH UPDATE LACTATION STATUS^790.16^Lactating:^Lactation^2^"
  1.  S WVTYPES("B","P")=4,WVTYPES("B","L")=5
  1.  S WVEXTERNAL(1)="Yes",WVEXTERNAL(0)="No",WVEXTERNAL(-1)="Not Applicable",WVEXTERNAL(2)="Do not know"
  1.  Q
  1. GETSUB(WVDFN) ;RETURN ^XTMP CACHE SUBSCRIPT
  1.  Q "WV_CCS;"_WVDFN