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

PXRMCWH.m

Go to the documentation of this file.
PXRMCWH ;SLC/AGP - Computed findings for WH project. ;10/14/2017
 ;;2.0;CLINICAL REMINDERS;**1,4,45**;Feb 4, 2005;Build 566
 ;
GETTEST(WVIEN,CNT,INC,TEXT,PXRMDIAG) ;
 N NUM,TEMP,Y
 D GETTEST^WVRPCGF1(+$P(FINDVAL,":",X),.TEMP,.PXRMDIAG)
 S NUM=0 F  S NUM=$O(TEMP(NUM)) Q:NUM'>0  S INC=INC+1,TEXT(CNT,INC)=TEMP(NUM)
 ;K ^TMP("WV RPT",$J)
 ;D EN^WVALERTR(+WVIEN,.PXRMDIAG)
 ;I '$D(^TMP("WV RPT",$J)) S TEXT(CNT,1)="No Test Found" Q
 ;S Y=0 F  S Y=$O(^TMP("WV RPT",$J,Y)) Q:Y'>0  S INC=INC+1,TEXT(CNT,INC)=$G(^TMP("WV RPT",$J,Y,0))
 ;K ^TMP("WV RPT",$J)
 Q
 ;
GETWVTXT(DAS,NFOUND,INC,TEXT) ;
 N X,TEMP,TCNT,WVIEN
 F X=1:1:$L(DAS,":") D
 .S WVIEN=$P(DAS,":",X)
 .K TEMP
 .S TCNT=0
 .D GETWVP^PXRMCEOC(DFN,WVIEN,"","",1,.TEMP,.TCNT)
 .S TCNT=0 F  S TCNT=$O(TEMP(1,TCNT)) Q:TCNT'>0  D
 ..S INC=INC+1,TEXT(NFOUND,INC)=TEMP(1,TCNT)_"\\"
 Q
 ;
GETBRTST(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
 N DTE,WVIEN
 S NFOUND=0,WVIEN=0
 S DTE=$S(+EDT>0:$$FMADD^XLFDT($P(EDT,"."),1),1:"")
 F  S DTE=$O(^WV(790.1,"AC",DFN,DTE),-1) Q:DTE=""!(WVIEN>0)!(NFOUND=NGET)!(DTE<BDT)  D
 .S WVIEN=$O(^WV(790.1,"AC",DFN,DTE,""),-1)
 .S NFOUND=NFOUND+1
 .D PROCDURE("","",WVIEN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)
 Q
 ;
MAM(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
 ;mammogram screening and review
 ;
 N CNT,CNT1,RESULT,WHDATE
 S NGET=$S(NGET<0:-NGET,1:NGET)
 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
 D LATEST^WVRPCPR(.RESULT,DFN,"M",$G(WHDATE),$G(NGET),"*")
 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
 I $G(CNT1)>0 S NFOUND=CNT1
 Q
 ;
MAMA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
 ;mammogram abnormal result
 ;
 N CNT,CNT1,RESULT,WHDATE
 S NGET=$S(NGET<0:-NGET,1:NGET)
 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
 D LATEST^WVRPCPR(.RESULT,DFN,"M",$G(WHDATE),$G(NGET),"A")
 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
 I $G(CNT1)>0 S NFOUND=CNT1
 Q
 ;
PAP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed
 ;finding for pap smear screening and review
 ;
 N CNT,CNT1,RESULT,WHDATE
 S NGET=$S(NGET<0:-NGET,1:NGET)
 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
 D LATEST^WVRPCPR(.RESULT,DFN,"P",$G(WHDATE),$G(NGET),"*")
 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
 I $G(CNT1)>0 S NFOUND=CNT1
 Q
 ;
 ;
PAPA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
 ;pap smear abnormal result
 ;
 N CNT,CNT1,RESULT,WHDATE
 S NGET=$S(NGET<0:-NGET,1:NGET)
 S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
 I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
 D LATEST^WVRPCPR(.RESULT,DFN,"P",$G(WHDATE),$G(NGET),"A")
 I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
 I $G(CNT1)>0 S NFOUND=CNT1
 Q
 ;
 ;
PROCESS(RESULT,CNT1,TEST,DATA,TEXT,NGET,BDT,EDT,NFOUND) ;
 ;Pieces out data in Result for Reminder evaluation
 N DATE1
 I $P($G(RESULT(0)),U)<0 Q
 F  S CNT=$O(RESULT(CNT)) Q:CNT=""!(CNT1>$G(NGET))  I CNT'=0 D
 . S DATE1=$P($G(RESULT(CNT)),U,3)
 . I $G(BDT)'="",$G(EDT)'="",EDT<BDT Q
 . S CNT1=CNT1+1
 . S TEST(CNT1)=0
 . S DATA(CNT1,"LINK")=$P($G(RESULT(CNT)),U,7)
 . S DATA(CNT1,"STATUS")=$P($G(RESULT(CNT)),U,8)
 . S DATA(CNT1,"VALUE")=$P($G(RESULT(CNT)),U,5)
 . S DATA(CNT1,"WVIEN")=$P($G(RESULT(CNT)),U)
 . S TEST(CNT1)=1,DATE(CNT1)=$G(DATE1)
 . S TEXT(CNT1)=$P($G(RESULT(CNT)),U,4)_" "_$P($G(RESULT(CNT)),U,6)
 . ;S VALUE(CNT1)=$P($G(RESULT(CNT)),U,5)
 Q
 ;
PAPSCR(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
 ;pap smear screening and f/u
 ;
 N CNT,CNT1,CNT2,DATE1,DS,EDTT,IND,JND,MOR,MORIEN,NODE,OD
 N PXRMWVT,PXRMWVM
 N SDIR,SNOWCNT,TDATA,TDATE,TOP,TTEST,TTEXT,SNOWTOP,NODE,WVPAP
 N DAS,DAS0,DAS1,DAS2,DAS3,DAS4,DAS5
 S NFOUND=0
 S WVPAP=$O(^WV(790.2,"B","PAP SMEAR",""))
 S SNOWCNT=0,CNT=0
 ;Get SNOMED Morphology codes from file 790.2
 F  S SNOWCNT=$O(^WV(790.2,WVPAP,1,SNOWCNT)) Q:+SNOWCNT'>0  D
 .S PXRMWVM($P($G(^WV(790.2,WVPAP,1,SNOWCNT,0)),U))=$P($G(^WV(790.2,WVPAP,1,SNOWCNT,0)),U,2)
 ;
 ;Get SNOMED Topography codes from file 790.2
 S SNOWCNT=0 F  S SNOWCNT=$O(^WV(790.2,WVPAP,2,SNOWCNT)) Q:+SNOWCNT'>0  D
 .S PXRMWVT($P($G(^WV(790.2,WVPAP,2,SNOWCNT,0)),U))=""
 ;
 ;If no topography codes quit
 I $D(PXRMWVT)'>0 S DATA(1,"VALUE")="NO TOPOGRAPHY CODES FOUND",TEST(1)=0,TEXT(1)="     " Q
 ;
 ;Handle search direction and date ranges
 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
 S SDIR=$S(NGET<0:+1,1:-1)
 S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
 S NGET=$S(NGET<0:-NGET,1:NGET)
 ;
 ;Match Topography codes in PXRMINDX for Lab
 N DTARRAY,NODE1,TCNT,ODATE1
 S TOP=0,CNT1=0,TCNT=0,ODATE1=0 F  S TOP=$O(PXRMWVT(TOP)) Q:+TOP'>0!(CNT1=NGET)  D
 .S SNOWTOP="A;O;"_TOP,DATE1=DS
 .F  S DATE1=+$O(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1),SDIR) Q:$S(DATE1'>0:1,DATE1<BDT:1,DATE1>EDTT:1,1:0)  D
 ..S DAS=$O(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1,""))
 ..;
 ..;set date to dtarray to hanle multiple snomed done on the same date
 ..S DTARRAY(DATE1)=$S($D(DTARRAY(DATE1)):DTARRAY(DATE1)+1,1:1)
 ..S DTARRAY(DATE1,DTARRAY(DATE1))=TOP_U_DAS
 ;
 ;loop through date array
 N DAS
 S DATE1=DS F  S DATE1=$O(DTARRAY(DATE1),SDIR) Q:$S(DATE1'>0:1,CNT1=NGET:1,1:0)  D
 .S TCNT=0,CNT1=CNT1+1 F  S TCNT=$O(DTARRAY(DATE1,TCNT)) Q:TCNT'>0  D
 ..S NODE1=$G(DTARRAY(DATE1,TCNT))
 ..S TDATE(CNT1)=DATE1,NODE=$G(^LAB(61,$P(NODE1,U),0)),DAS=$P(NODE1,U,2)
 ..S TTEST(CNT1)=0
 ..;
 ..;set TDATA to value
 ..S TDATA(CNT1,"SNOMED",TCNT,"VALUE")="T-"_$P(NODE,U,2)_" "_$P(NODE,U)
 ..I '$D(TTEXT(CNT1)) S TTEXT(CNT1)=TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
 ..E  I $L(TTEXT(CNT1))+$L(TDATA(CNT1,"SNOMED",TCNT,"VALUE"))<255 D
 ...I $E(TTEXT(CNT1),$L(TTEXT(CNT1)))="\" S TTEXT(CNT1)=TTEXT(CNT1)_TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
 ..S TDATA(CNT1,"SNOMED",TCNT,"TOPH")="T-"_$P(NODE,U,2)
 ..;
 ..;Dig down into Lab file to find a match for morphology codes
 ..S SNOWCNT=0,DAS0=$P($G(DAS),";"),DAS1=$P($G(DAS),";",3)
 ..S DAS2=$P(DAS,";",4),DAS3=$P(DAS,";",5)
 ..S CNT2=0,NODE=""
 ..;
 ..;get Morphology results
 ..N MCNT S MCNT=0
 ..S TDATA(CNT1,"UNSATISFACTORY")="F"
 ..F  S SNOWCNT=$O(^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT)) Q:+SNOWCNT'>0  D
 ...S MORIEN=^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT,0)
 ...I $D(PXRMWVM(MORIEN))>0 D
 ....S TTEST(CNT1)=1,MCNT=MCNT+1
 ....;
 ....;handle multiple SNOMED entries for the same date
 ....S NODE=^LAB(61.1,MORIEN,0)
 ....N STR
 ....I '$D(TTEXT(CNT1))  S TTEXT(CNT1)="M-"_$P(NODE,U,2)_" "_$P(NODE,U)
 ....E  D
 .....S STR="M-"_$P(NODE,U,2)_" "_$P(NODE,U)
 .....I $L(TTEXT(CNT1))+STR'<255 Q
 .....S TTEXT(CNT1)=TTEXT(CNT1)_STR_";"
 ....;
 ....S TDATA(CNT1,"SNOMED",TCNT,MCNT,"MORP")="M-"_$P(NODE,U,2)
 ....S TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")=$S(PXRMWVM(MORIEN)="0":"NEM",PXRMWVM(MORIEN)="1":"Abnormal",PXRMWVM(MORIEN)="2":"Unsatisfactory",1:"Unknown")
 ....I TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")["Un" S TDATA(CNT1,"UNSATISFACTORY")="T"
 ....I $L(TTEXT(CNT1))+$L("\\")<255 S TTEXT(CNT1)=TTEXT(CNT1)_"\\"
 S NFOUND=CNT1
 N DATE1,CNT,TCNT
 F IND=1:1:NFOUND S OD(TDATE(IND),IND)=""
 S CNT1=0,IND=""
 F  S IND=$O(OD(IND),SDIR) Q:IND=""  D
 . S JND=0
 . F  S JND=$O(OD(IND,JND)) Q:JND=""  D
 .. S CNT1=CNT1+1
 .. S DATE(CNT1)=IND
 .. S TEST(CNT1)=TTEST(JND)
 .. M DATA(CNT1)=TDATA(JND)
 .. S TEXT(CNT1)=TTEXT(JND)
 Q
 ;
NEXTPROC(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
 N NAME,NODE,TYPE
 S NFOUND=0
 S TYPE=TEST I TYPE="" Q
 S NODE=$$NEXTPROC^WVRPCGF1(DFN,TYPE)
 I NODE="" Q
 S TEST(1)=1
 S DATA(1,"Procedure")=$P(NODE,U)
 S DATE(1)=$P(NODE,U,2)
 S TEXT(1)="Procedure: "_$P(NODE,U)
 S NFOUND=1
 Q
 ;
NOOPEN(WVIEN,PAT,ONDATE,EDT) ;
 N ACCESS,CNT,NOOPEN,NODE,TEMP,WVNIEN,WVNNODE
 S NODE=$G(^WV(790.1,WVIEN,0)) Q:NODE=""
 I $P(NODE,U,36)="T" Q 1
 S ACCESS=$P(NODE,U)
 ;I '$D(^WV(790.4,"C",ACCESS)) Q 0
 S WVNIEN=0,NOOPEN=1
 F  S WVNIEN=$O(^WV(790.4,"C",ACCESS,WVNIEN)) Q:WVNIEN'>0  D
 .S WVNNODE=$G(^WV(790.4,WVNIEN,0)) Q:WVNNODE=""
 .I ONDATE>0,ONDATE>+$P(WVNNODE,U,2) Q
 .I EDT>0,$$FMADD^XLFDT(EDT,1)<+$P(WVNNODE,U,2) Q
 .S NOOPEN=$S(+$P(WVNNODE,U,3)=0:0,1:1)
 Q NOOPEN
 ;
NONOTIFL(NGET,BDT,EDT,PLIST,PARAM) ;
 N DTE,EPNAME,IEN,INC,NODE,PAT,WVIEN,WVNODE
 S EPNAME=PARAM
 S PAT=0 F  S PAT=$O(^PXRM(809,"C",PAT)) Q:PAT'>0  D
 .S DTE=0 F  S DTE=$O(^PXRM(809,"C",PAT,EPNAME,DTE)) Q:DTE'>0  D
 ..S IEN=$O(^PXRM(809,"C",PAT,EPNAME,DTE,"")) Q:IEN'>0
 ..S INC=0 F  S INC=$O(^PXRM(809,IEN,1,INC)) Q:INC'>0  D
 ...S NODE=$G(^PXRM(809,IEN,1,INC,0))
 ...I $P(NODE,U)'["WV(790.1" Q
 ...S WVIEN=+$P(NODE,U)
 ...I $$NOOPEN(WVIEN,PAT,+BDT,+EDT) Q
 ...S WVNODE=$G(^WV(790.1,WVIEN,0))
 ...S ^TMP($J,PLIST,PAT,1)=U_$S(+$P(WVNODE,U,12)>0:$P(WVNODE,U,12),1:DTE)_U_790.1_U_WVIEN_U
 Q
 ;
NONOTIFD(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
 N DAS,DTE,EPNAME,INC,NODE,NUMOPEN,PXRMARYD,WVIEN,WVNODE
 S DAS="",EPNAME=TEST,NFOUND=0,NUMOPEN=0,PXRMARYD=""
 I '$D(^PXRM(809,"C",DFN,EPNAME)) Q
 S DTE=0 F  S DTE=$O(^PXRM(809,"C",DFN,EPNAME,DTE)) Q:DTE'>0  D
 .S IEN=$O(^PXRM(809,"C",DFN,EPNAME,DTE,"")) Q:IEN'>0
 .S INC=0 F  S INC=$O(^PXRM(809,IEN,1,INC)) Q:INC'>0  D
 ..S NODE=$G(^PXRM(809,IEN,1,INC,0))
 ..I $P(NODE,U)'["WV(790.1" Q
 ..S WVIEN=+$P(NODE,U)
 ..I $$NOOPEN(WVIEN,DFN,+BDT,+EDT) Q
 ..S NFOUND=NFOUND+1
 ..;S TEST(NFOUND)=1
 ..S WVNODE=$G(^WV(790.1,WVIEN,0)) Q:WVNODE=""
 ..S NUMOPEN=NUMOPEN+1
 ..I DAS[WVIEN Q
 ..S DAS=$S(NUMOPEN=1:WVIEN_",",1:DAS_":"_WVIEN_",")
 ..;D PROCDURE("",.PXRMARYD,WVIEN,.NGET,BDT,EDT,NFOUND,.TEST,.DATE,.DATA,.TEXT)
 ..;S DATA(NFOUND,"DAS")=WVIEN_",",DATE(NFOUND)=$P(WVNODE,U,12)
 ..;S DATA(NFOUND,"PROVIDER")=$P(WVNODE,U,7)
 I DAS="" Q
 S NFOUND=1
 S TEST(NFOUND)=1
 S DATA(NFOUND,"Number of procedures with open notification")=NUMOPEN
 S DATA(NFOUND,"DAS")=DAS
 ;S DATA(NFOUND,"Cascade Name")=EPNAME
 ;S DATA(NFOUND,"WV Procedure ID")=NOTID
 S DATE(NFOUND)=DT
 S DATA(1,"DIALOG")=1
 S DATA(1,"PACKAGE")="WOMEN'S HEALTH"
 S DATA(1,"PACKAGE PREFIX")="WV"
 S INC=0 D GETWVTXT(DAS,NFOUND,.INC,.TEXT)
 Q
 ;
OPNRPRCL(NGET,BDT,EDT,PLIST,PARAM) ;
 N BEG,END,NODE,WVIEN
 S DATE=$S(BDT>0:BDT,1:0)
 S EDT=$S(EDT<DT:EDT,1:DT)
 F  S DATE=$O(^WV(790.1,"ARADOPEN",DATE)) Q:DATE'>0!(DATE>EDT)  D
 .S WVIEN=0 F  S WVIEN=$O(^WV(790.1,"ARADOPEN",DATE,WVIEN)) Q:WVIEN'>0  D
 ..S NODE=$G(^WV(790.1,WVIEN,0))
 Q
 ;
OPENPROC(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
 N DAS,DIAGNFND,DIAGNOS,DIAGS,EPNAME,EPIEN,INC,NODE,NOTID,NUMOPEN,PXRMDIAG,TMP,WVDATE,WVDX,WVIEN,WVNODE
 S EPNAME=TEST,NFOUND=0
 S EPIEN=+$O(^PXRM(809,"OPEN",DFN,EPNAME,""))
 I EPIEN=0 Q
 S NUMOPEN=0,DIAGNFND=0
 S INC=0 F  S INC=$O(^PXRM(809,EPIEN,1,INC)) Q:INC'>0  D
 .K WDX
 .S NODE=$G(^PXRM(809,EPIEN,1,INC,0))
 .I $P(NODE,U)'["WV(790.1" Q
 .S WVIEN=+$P(NODE,U)
 .S WVNODE=$G(^WV(790.1,WVIEN,0))
 .I $P(WVNODE,U,15)="" Q
 .I $P(WVNODE,U,14)="c" Q
 .S NUMOPEN=NUMOPEN+1
 .S DAS=$S(NUMOPEN=1:WVIEN_",",1:DAS_":"_WVIEN_",")
 .S NOTID=$S(NUMOPEN=1:WVIEN,1:NOTID_":"_WVIEN)
 .S WVDATE=$P(WVNODE,U,12)
 .I +$P(WVNODE,U,5)>0 D  Q
 ..S WDX=$P($G(^WV(790.31,+$P(WVNODE,U,5),0)),U)
 ..I WDX="" S DIAGNFND=1
 ..S DIAGS(WDX)=""
 .S DIAGNFND=1
 I NUMOPEN=0 Q
 I $G(DAS)="" Q
 S NFOUND=NFOUND+1
 S TEST(NFOUND)=1
 S DATA(NFOUND,"Number of Test Open")=NUMOPEN
 S DATA(NFOUND,"DAS")=DAS
 ;S DATA(NFOUND,"Cascade Name")=EPNAME
 ;S DATA(NFOUND,"WV Procedure ID")=NOTID
 S DATE(NFOUND)=DT
 S DATA(1,"DIALOG")=1
 S DATA(1,"PACKAGE")="WOMEN'S HEALTH"
 S DATA(1,"PACKAGE PREFIX")="WV"
 S INC=0 D GETWVTXT(DAS,NFOUND,.INC,.TEXT)
 I DIAGNFND=1 Q
 S TMP="",WDX="" F  S TMP=$O(DIAGS(TMP)) Q:TMP=""!(DIAGNFND=1)  D
 .I TMP'["BI-RADS" S DIAGNFND=1 Q
 .S WDX=TMP
 I WDX="" Q
 I DIAGNFND=1 Q
 S DATA(NFOUND,"DIAGNOSIS")=WDX
 Q
 ;
PROCNNOT(ALTID,PXRMARYD,WVIEN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
 N ACCESS,DCNT,INC,NODE,PUR,PURIEN,PXRMDIAG,WNIEN
 S TEST(NFOUND)=1
 S INC=0
 D GETTEST(WVIEN,NFOUND,.INC,.TEXT,.PXRMDIAG)
 S NODE=$G(^WV(790.1,WVIEN,0))
 S ACCESS=$P(NODE,U) Q:ACCESS=""
 S DATA(NFOUND,"ACCESSION")=$P(NODE,U)
 S DATA(NFOUND,"STATUS")=$S($P(NODE,U,14)="c":"CLOSED",$P(NODE,U,14)="o":"OPEN",1:"UNKNOWN")
 S DATE(NFOUND)=$P(NODE,U,12)
 S INC=INC+1,TEXT(NFOUND,INC)=""
 S INC=INC+1,TEXT(NFOUND,INC)="Notification Purpose(s):"
 S WNIEN=0,DCNT=0 F  S WNIEN=$O(^WV(790.4,"C",ACCESS,WNIEN)) Q:WNIEN'>0  D
 .S NODE=$G(^WV(790.4,WNIEN,0)) Q:NODE=""
 .I +$P(NODE,U,8)>0 Q
 .S PURIEN=$P(NODE,U,4) Q:PURIEN'>0
 .S PUR=$P($G(^WV(790.404,PURIEN,0)),U)
 .S INC=INC+1,TEXT(NFOUND,INC)=PUR
 .S DCNT=DCNT+1,DATA(NFOUND,"Notification Purpose",DCNT)=PUR
 S DATA(1,"DIALOG")=1
 S DATA(1,"PACKAGE")="WOMEN'S HEALTH"
 S DATA(1,"PACKAGE PREFIX")="WV"
 S DATA(1,"DAS")=WVIEN_","
 Q
 ;
PROCDURE(ALTID,PXRMARYD,WVIEN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
 N CASE,DIAG,DTE,INC,ISFALT,NODE,PROCNAME,RESULT,Y
 S ISFALT=0
 I ALTID'="",PXRMARYD'="",WVIEN>0 S ISFALT=1
 S NODE=$G(^WV(790.1,WVIEN,0))
 S DATA(NFOUND,"DIALOG")=1
 S DATA(NFOUND,"PACKAGE")="WOMEN'S HEALTH"
 S DATA(NFOUND,"PACKAGE PREFIX")="WV"
 S DATA(NFOUND,"DAS")=WVIEN_","
 S DATA(NFOUND,"ACCESSION")=$P(NODE,U)
 S DATA(NFOUND,"STATUS")=$S($P(NODE,U,14)="c":"CLOSED",$P(NODE,U,14)="I":"IN PROCESS",$P(NODE,U,14)="o":"OPEN",1:"UNKNOWN")
 S DATA(NFOUND,"PROVIDER")=$P(NODE,U,7)
 S DATE(NFOUND)=$P(NODE,U,12)
 S TEST(NFOUND)=1
 S DIAG=$P(NODE,U,5)
 I +DIAG>0 S DATA(NFOUND,"DIAGNOSIS")=$P($G(^WV(790.31,DIAG,0)),U)
 S INC=0 S INC=0 D GETWVTXT(WVIEN,NFOUND,.INC,.TEXT)
 S DATE(NFOUND)=$S($P(NODE,U,12)>0:$P(NODE,U,12),1:DT)
 Q
 ;
BROVRDUE(NGET,BDT,EDT,PLIST,PARAM) ;
 N DATE,PAT,PXRMARR
 I PARAM="" Q
 D BRNEEDS^WVRPCGF1(.PXRMARR,BDT,EDT,PARAM)
 S PAT=0 F  S PAT=$O(PXRMARR(PAT)) Q:PAT'>0  S ^TMP($J,PLIST,PAT,1)=U_+$G(PXRMARR(PAT))_U_790_U_PAT_U
 Q
 ;