PXRMCWH ;SLC/AGP - Computed findings for WH project. ;03/09/2022
;;2.0;CLINICAL REMINDERS;**1,4,45,71,80**;Feb 4, 2005;Build 7
;
;SACC EXEMPTIONS SECTION
;2.3.1.10.1 and 2.3.1.10.2
;
;DBIA USED
;6776 GETTEST^WVRPCGF1,$$NEXTPROC^WVRPCGF1,BRNEEDS^WVRPCGF1
;4105 LATEST^WVRPCPR
;4501 ^WV(790.2,
;4179 ^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT
;4246 ^LAB(61.1
;6824 ^WV(790.1
;7246 RADCASE^WVALERTR,RADREP^WVALERTR
;
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 TEST(1)=0
S NFOUND=0
S TYPE=TEST I TYPE="" Q
S NODE=$$NEXTPROC^WVRPCGF1(DFN,TYPE)
I NODE="" Q
I BDT>0,+$P(NODE,U,2)'>BDT Q
I EDT>0,$P(EDT,".")>$P(BDT,"."),$P(EDT,".")>DT,+$P(NODE,U,2)>EDT 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
;
COMPTERM(WVIEN,TERMLARR) ;
N IDX,NAME,NODE,WVPIEN,WVPTYPE,RESULT,TIEN
S RESULT=0
S NODE=$G(^WV(790.1,WVIEN,0))
S WVPIEN=$P(NODE,U,4)
S TIEN=+$P($G(^WV(790.2,WVPIEN,3)),U) I TIEN=0 Q RESULT
S NAME=$P($G(^PXRMD(811.5,TIEN,0)),U) I NAME="" Q RESULT
S IDX=0 F S IDX=$O(TERMLARR(IDX)) Q:IDX'>0!(RESULT=1) D
.I NAME=$G(TERMLARR(IDX)) S RESULT=1
Q RESULT
;
OPENPROC(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
N CNT,DAS,DIAGNFND,DIAGNOS,DIAGS,EPNAME,EPIEN,INC,MAX,NODE,NOTID,NUMOPEN
N PXRMDIAG,SECDX,SECDXS,TERMLARR,TMP,WVDATE,WVDX,WVIEN,WVIENS,WVNODE,WVRPTIEN,WVSECDX
S EPNAME=TEST,NFOUND=0
S MAX=$$BLDTARR^PXRMPRAD(.TERMLARR)
;F X=1:1:MAX
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,12)<BDT Q
.I $P(WVNODE,U,15)="" Q
.I $P(WVNODE,U,14)="c" Q
.I '$$COMPTERM(WVIEN,.TERMLARR) Q
.K WVSECDX,WVIENS,WVRPTIEN
.D RADCASE^WVALERTR(WVIEN,.WVSECDX,.WVIENS,.WVRPTIEN)
.I +$G(WVRPTIEN)=0 Q
.S CNT=0 F S CNT=$O(WVSECDX("S",CNT)) Q:CNT'>0 D
..S SECDXS(WVSECDX("S",CNT))=""
.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)
S SECDX="",INC=0 F S SECDX=$O(SECDXS(SECDX)) Q:SECDX="" D
.S INC=INC+1,DATA(NFOUND,"SECONDARY DIAGNOSIS",INC)=SECDX
I DIAGNFND=1 Q
;S TMP=DIAGS("P")
;I TMP'["BI-RADS" S DIAGNFND=1
;E S WDX=TMP
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCWH 15390 printed Dec 13, 2024@01:43:27 Page 2
PXRMCWH ;SLC/AGP - Computed findings for WH project. ;03/09/2022
+1 ;;2.0;CLINICAL REMINDERS;**1,4,45,71,80**;Feb 4, 2005;Build 7
+2 ;
+3 ;SACC EXEMPTIONS SECTION
+4 ;2.3.1.10.1 and 2.3.1.10.2
+5 ;
+6 ;DBIA USED
+7 ;6776 GETTEST^WVRPCGF1,$$NEXTPROC^WVRPCGF1,BRNEEDS^WVRPCGF1
+8 ;4105 LATEST^WVRPCPR
+9 ;4501 ^WV(790.2,
+10 ;4179 ^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT
+11 ;4246 ^LAB(61.1
+12 ;6824 ^WV(790.1
+13 ;7246 RADCASE^WVALERTR,RADREP^WVALERTR
+14 ;
GETTEST(WVIEN,CNT,INC,TEXT,PXRMDIAG) ;
+1 NEW NUM,TEMP,Y
+2 DO GETTEST^WVRPCGF1(+$PIECE(FINDVAL,":",X),.TEMP,.PXRMDIAG)
+3 SET NUM=0
FOR
SET NUM=$ORDER(TEMP(NUM))
if NUM'>0
QUIT
SET INC=INC+1
SET TEXT(CNT,INC)=TEMP(NUM)
+4 ;K ^TMP("WV RPT",$J)
+5 ;D EN^WVALERTR(+WVIEN,.PXRMDIAG)
+6 ;I '$D(^TMP("WV RPT",$J)) S TEXT(CNT,1)="No Test Found" Q
+7 ;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))
+8 ;K ^TMP("WV RPT",$J)
+9 QUIT
+10 ;
GETWVTXT(DAS,NFOUND,INC,TEXT) ;
+1 NEW X,TEMP,TCNT,WVIEN
+2 FOR X=1:1:$LENGTH(DAS,":")
Begin DoDot:1
+3 SET WVIEN=$PIECE(DAS,":",X)
+4 KILL TEMP
+5 SET TCNT=0
+6 DO GETWVP^PXRMCEOC(DFN,WVIEN,"","",1,.TEMP,.TCNT)
+7 SET TCNT=0
FOR
SET TCNT=$ORDER(TEMP(1,TCNT))
if TCNT'>0
QUIT
Begin DoDot:2
+8 SET INC=INC+1
SET TEXT(NFOUND,INC)=TEMP(1,TCNT)_"\\"
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
GETBRTST(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
+1 NEW DTE,WVIEN
+2 SET NFOUND=0
SET WVIEN=0
+3 SET DTE=$SELECT(+EDT>0:$$FMADD^XLFDT($PIECE(EDT,"."),1),1:"")
+4 FOR
SET DTE=$ORDER(^WV(790.1,"AC",DFN,DTE),-1)
if DTE=""!(WVIEN>0)!(NFOUND=NGET)!(DTE<BDT)
QUIT
Begin DoDot:1
+5 SET WVIEN=$ORDER(^WV(790.1,"AC",DFN,DTE,""),-1)
+6 SET NFOUND=NFOUND+1
+7 DO PROCDURE("","",WVIEN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)
End DoDot:1
+8 QUIT
+9 ;
MAM(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
+1 ;mammogram screening and review
+2 ;
+3 NEW CNT,CNT1,RESULT,WHDATE
+4 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+5 SET (CNT1,CNT,NFOUND)=0
SET DATE=$$NOW^PXRMDATE
SET TEST(1)=0
+6 IF $GET(BDT)'=""
IF $GET(EDT)'=""
SET WHDATE=BDT_U_EDT
+7 DO LATEST^WVRPCPR(.RESULT,DFN,"M",$GET(WHDATE),$GET(NGET),"*")
+8 IF $DATA(RESULT)>0
DO PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
+9 IF $GET(CNT1)>0
SET NFOUND=CNT1
+10 QUIT
+11 ;
MAMA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
+1 ;mammogram abnormal result
+2 ;
+3 NEW CNT,CNT1,RESULT,WHDATE
+4 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+5 SET (CNT1,CNT,NFOUND)=0
SET DATE=$$NOW^PXRMDATE
SET TEST(1)=0
+6 IF $GET(BDT)'=""
IF $GET(EDT)'=""
SET WHDATE=BDT_U_EDT
+7 DO LATEST^WVRPCPR(.RESULT,DFN,"M",$GET(WHDATE),$GET(NGET),"A")
+8 IF $DATA(RESULT)>0
DO PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
+9 IF $GET(CNT1)>0
SET NFOUND=CNT1
+10 QUIT
+11 ;
PAP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed
+1 ;finding for pap smear screening and review
+2 ;
+3 NEW CNT,CNT1,RESULT,WHDATE
+4 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+5 SET (CNT1,CNT,NFOUND)=0
SET DATE=$$NOW^PXRMDATE
SET TEST(1)=0
+6 IF $GET(BDT)'=""
IF $GET(EDT)'=""
SET WHDATE=BDT_U_EDT
+7 DO LATEST^WVRPCPR(.RESULT,DFN,"P",$GET(WHDATE),$GET(NGET),"*")
+8 IF $DATA(RESULT)>0
DO PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
+9 IF $GET(CNT1)>0
SET NFOUND=CNT1
+10 QUIT
+11 ;
+12 ;
PAPA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
+1 ;pap smear abnormal result
+2 ;
+3 NEW CNT,CNT1,RESULT,WHDATE
+4 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+5 SET (CNT1,CNT,NFOUND)=0
SET DATE=$$NOW^PXRMDATE
SET TEST(1)=0
+6 IF $GET(BDT)'=""
IF $GET(EDT)'=""
SET WHDATE=BDT_U_EDT
+7 DO LATEST^WVRPCPR(.RESULT,DFN,"P",$GET(WHDATE),$GET(NGET),"A")
+8 IF $DATA(RESULT)>0
DO PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
+9 IF $GET(CNT1)>0
SET NFOUND=CNT1
+10 QUIT
+11 ;
+12 ;
PROCESS(RESULT,CNT1,TEST,DATA,TEXT,NGET,BDT,EDT,NFOUND) ;
+1 ;Pieces out data in Result for Reminder evaluation
+2 NEW DATE1
+3 IF $PIECE($GET(RESULT(0)),U)<0
QUIT
+4 FOR
SET CNT=$ORDER(RESULT(CNT))
if CNT=""!(CNT1>$GET(NGET))
QUIT
IF CNT'=0
Begin DoDot:1
+5 SET DATE1=$PIECE($GET(RESULT(CNT)),U,3)
+6 IF $GET(BDT)'=""
IF $GET(EDT)'=""
IF EDT<BDT
QUIT
+7 SET CNT1=CNT1+1
+8 SET TEST(CNT1)=0
+9 SET DATA(CNT1,"LINK")=$PIECE($GET(RESULT(CNT)),U,7)
+10 SET DATA(CNT1,"STATUS")=$PIECE($GET(RESULT(CNT)),U,8)
+11 SET DATA(CNT1,"VALUE")=$PIECE($GET(RESULT(CNT)),U,5)
+12 SET DATA(CNT1,"WVIEN")=$PIECE($GET(RESULT(CNT)),U)
+13 SET TEST(CNT1)=1
SET DATE(CNT1)=$GET(DATE1)
+14 SET TEXT(CNT1)=$PIECE($GET(RESULT(CNT)),U,4)_" "_$PIECE($GET(RESULT(CNT)),U,6)
+15 ;S VALUE(CNT1)=$P($G(RESULT(CNT)),U,5)
End DoDot:1
+16 QUIT
+17 ;
PAPSCR(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
+1 ;pap smear screening and f/u
+2 ;
+3 NEW CNT,CNT1,CNT2,DATE1,DS,EDTT,IND,JND,MOR,MORIEN,NODE,OD
+4 NEW PXRMWVT,PXRMWVM
+5 NEW SDIR,SNOWCNT,TDATA,TDATE,TOP,TTEST,TTEXT,SNOWTOP,NODE,WVPAP
+6 NEW DAS,DAS0,DAS1,DAS2,DAS3,DAS4,DAS5
+7 SET NFOUND=0
+8 SET WVPAP=$ORDER(^WV(790.2,"B","PAP SMEAR",""))
+9 SET SNOWCNT=0
SET CNT=0
+10 ;Get SNOMED Morphology codes from file 790.2
+11 FOR
SET SNOWCNT=$ORDER(^WV(790.2,WVPAP,1,SNOWCNT))
if +SNOWCNT'>0
QUIT
Begin DoDot:1
+12 SET PXRMWVM($PIECE($GET(^WV(790.2,WVPAP,1,SNOWCNT,0)),U))=$PIECE($GET(^WV(790.2,WVPAP,1,SNOWCNT,0)),U,2)
End DoDot:1
+13 ;
+14 ;Get SNOMED Topography codes from file 790.2
+15 SET SNOWCNT=0
FOR
SET SNOWCNT=$ORDER(^WV(790.2,WVPAP,2,SNOWCNT))
if +SNOWCNT'>0
QUIT
Begin DoDot:1
+16 SET PXRMWVT($PIECE($GET(^WV(790.2,WVPAP,2,SNOWCNT,0)),U))=""
End DoDot:1
+17 ;
+18 ;If no topography codes quit
+19 IF $DATA(PXRMWVT)'>0
SET DATA(1,"VALUE")="NO TOPOGRAPHY CODES FOUND"
SET TEST(1)=0
SET TEXT(1)=" "
QUIT
+20 ;
+21 ;Handle search direction and date ranges
+22 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+23 SET SDIR=$SELECT(NGET<0:+1,1:-1)
+24 SET DS=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
+25 SET NGET=$SELECT(NGET<0:-NGET,1:NGET)
+26 ;
+27 ;Match Topography codes in PXRMINDX for Lab
+28 NEW DTARRAY,NODE1,TCNT,ODATE1
+29 SET TOP=0
SET CNT1=0
SET TCNT=0
SET ODATE1=0
FOR
SET TOP=$ORDER(PXRMWVT(TOP))
if +TOP'>0!(CNT1=NGET)
QUIT
Begin DoDot:1
+30 SET SNOWTOP="A;O;"_TOP
SET DATE1=DS
+31 FOR
SET DATE1=+$ORDER(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1),SDIR)
if $SELECT(DATE1'>0
QUIT
Begin DoDot:2
+32 SET DAS=$ORDER(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1,""))
+33 ;
+34 ;set date to dtarray to hanle multiple snomed done on the same date
+35 SET DTARRAY(DATE1)=$SELECT($DATA(DTARRAY(DATE1)):DTARRAY(DATE1)+1,1:1)
+36 SET DTARRAY(DATE1,DTARRAY(DATE1))=TOP_U_DAS
End DoDot:2
End DoDot:1
+37 ;
+38 ;loop through date array
+39 NEW DAS
+40 SET DATE1=DS
FOR
SET DATE1=$ORDER(DTARRAY(DATE1),SDIR)
if $SELECT(DATE1'>0
QUIT
Begin DoDot:1
+41 SET TCNT=0
SET CNT1=CNT1+1
FOR
SET TCNT=$ORDER(DTARRAY(DATE1,TCNT))
if TCNT'>0
QUIT
Begin DoDot:2
+42 SET NODE1=$GET(DTARRAY(DATE1,TCNT))
+43 SET TDATE(CNT1)=DATE1
SET NODE=$GET(^LAB(61,$PIECE(NODE1,U),0))
SET DAS=$PIECE(NODE1,U,2)
+44 SET TTEST(CNT1)=0
+45 ;
+46 ;set TDATA to value
+47 SET TDATA(CNT1,"SNOMED",TCNT,"VALUE")="T-"_$PIECE(NODE,U,2)_" "_$PIECE(NODE,U)
+48 IF '$DATA(TTEXT(CNT1))
SET TTEXT(CNT1)=TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
+49 IF '$TEST
IF $LENGTH(TTEXT(CNT1))+$LENGTH(TDATA(CNT1,"SNOMED",TCNT,"VALUE"))<255
Begin DoDot:3
+50 IF $EXTRACT(TTEXT(CNT1),$LENGTH(TTEXT(CNT1)))="\"
SET TTEXT(CNT1)=TTEXT(CNT1)_TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
End DoDot:3
+51 SET TDATA(CNT1,"SNOMED",TCNT,"TOPH")="T-"_$PIECE(NODE,U,2)
+52 ;
+53 ;Dig down into Lab file to find a match for morphology codes
+54 SET SNOWCNT=0
SET DAS0=$PIECE($GET(DAS),";")
SET DAS1=$PIECE($GET(DAS),";",3)
+55 SET DAS2=$PIECE(DAS,";",4)
SET DAS3=$PIECE(DAS,";",5)
+56 SET CNT2=0
SET NODE=""
+57 ;
+58 ;get Morphology results
+59 NEW MCNT
SET MCNT=0
+60 SET TDATA(CNT1,"UNSATISFACTORY")="F"
+61 FOR
SET SNOWCNT=$ORDER(^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT))
if +SNOWCNT'>0
QUIT
Begin DoDot:3
+62 SET MORIEN=^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT,0)
+63 IF $DATA(PXRMWVM(MORIEN))>0
Begin DoDot:4
+64 SET TTEST(CNT1)=1
SET MCNT=MCNT+1
+65 ;
+66 ;handle multiple SNOMED entries for the same date
+67 SET NODE=^LAB(61.1,MORIEN,0)
+68 NEW STR
+69 IF '$DATA(TTEXT(CNT1))
SET TTEXT(CNT1)="M-"_$PIECE(NODE,U,2)_" "_$PIECE(NODE,U)
+70 IF '$TEST
Begin DoDot:5
+71 SET STR="M-"_$PIECE(NODE,U,2)_" "_$PIECE(NODE,U)
+72 IF $LENGTH(TTEXT(CNT1))+STR'<255
QUIT
+73 SET TTEXT(CNT1)=TTEXT(CNT1)_STR_";"
End DoDot:5
+74 ;
+75 SET TDATA(CNT1,"SNOMED",TCNT,MCNT,"MORP")="M-"_$PIECE(NODE,U,2)
+76 SET TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")=$SELECT(PXRMWVM(MORIEN)="0":"NEM",PXRMWVM(MORIEN)="1":"Abnormal",PXRMWVM(MORIEN)="2":"Unsatisfactory",1:"Unknown")
+77 IF TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")["Un"
SET TDATA(CNT1,"UNSATISFACTORY")="T"
+78 IF $LENGTH(TTEXT(CNT1))+$LENGTH("\\")<255
SET TTEXT(CNT1)=TTEXT(CNT1)_"\\"
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+79 SET NFOUND=CNT1
+80 NEW DATE1,CNT,TCNT
+81 FOR IND=1:1:NFOUND
SET OD(TDATE(IND),IND)=""
+82 SET CNT1=0
SET IND=""
+83 FOR
SET IND=$ORDER(OD(IND),SDIR)
if IND=""
QUIT
Begin DoDot:1
+84 SET JND=0
+85 FOR
SET JND=$ORDER(OD(IND,JND))
if JND=""
QUIT
Begin DoDot:2
+86 SET CNT1=CNT1+1
+87 SET DATE(CNT1)=IND
+88 SET TEST(CNT1)=TTEST(JND)
+89 MERGE DATA(CNT1)=TDATA(JND)
+90 SET TEXT(CNT1)=TTEXT(JND)
End DoDot:2
End DoDot:1
+91 QUIT
+92 ;
NEXTPROC(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
+1 NEW NAME,NODE,TYPE
+2 SET TEST(1)=0
+3 SET NFOUND=0
+4 SET TYPE=TEST
IF TYPE=""
QUIT
+5 SET NODE=$$NEXTPROC^WVRPCGF1(DFN,TYPE)
+6 IF NODE=""
QUIT
+7 IF BDT>0
IF +$PIECE(NODE,U,2)'>BDT
QUIT
+8 IF EDT>0
IF $PIECE(EDT,".")>$PIECE(BDT,".")
IF $PIECE(EDT,".")>DT
IF +$PIECE(NODE,U,2)>EDT
QUIT
+9 SET TEST(1)=1
+10 SET DATA(1,"Procedure")=$PIECE(NODE,U)
+11 SET DATE(1)=$PIECE(NODE,U,2)
+12 SET TEXT(1)="Procedure: "_$PIECE(NODE,U)
+13 SET NFOUND=1
+14 QUIT
+15 ;
NOOPEN(WVIEN,PAT,ONDATE,EDT) ;
+1 NEW ACCESS,CNT,NOOPEN,NODE,TEMP,WVNIEN,WVNNODE
+2 SET NODE=$GET(^WV(790.1,WVIEN,0))
if NODE=""
QUIT
+3 IF $PIECE(NODE,U,36)="T"
QUIT 1
+4 SET ACCESS=$PIECE(NODE,U)
+5 ;I '$D(^WV(790.4,"C",ACCESS)) Q 0
+6 SET WVNIEN=0
SET NOOPEN=1
+7 FOR
SET WVNIEN=$ORDER(^WV(790.4,"C",ACCESS,WVNIEN))
if WVNIEN'>0
QUIT
Begin DoDot:1
+8 SET WVNNODE=$GET(^WV(790.4,WVNIEN,0))
if WVNNODE=""
QUIT
+9 IF ONDATE>0
IF ONDATE>+$PIECE(WVNNODE,U,2)
QUIT
+10 IF EDT>0
IF $$FMADD^XLFDT(EDT,1)<+$PIECE(WVNNODE,U,2)
QUIT
+11 SET NOOPEN=$SELECT(+$PIECE(WVNNODE,U,3)=0:0,1:1)
End DoDot:1
+12 QUIT NOOPEN
+13 ;
NONOTIFL(NGET,BDT,EDT,PLIST,PARAM) ;
+1 NEW DTE,EPNAME,IEN,INC,NODE,PAT,WVIEN,WVNODE
+2 SET EPNAME=PARAM
+3 SET PAT=0
FOR
SET PAT=$ORDER(^PXRM(809,"C",PAT))
if PAT'>0
QUIT
Begin DoDot:1
+4 SET DTE=0
FOR
SET DTE=$ORDER(^PXRM(809,"C",PAT,EPNAME,DTE))
if DTE'>0
QUIT
Begin DoDot:2
+5 SET IEN=$ORDER(^PXRM(809,"C",PAT,EPNAME,DTE,""))
if IEN'>0
QUIT
+6 SET INC=0
FOR
SET INC=$ORDER(^PXRM(809,IEN,1,INC))
if INC'>0
QUIT
Begin DoDot:3
+7 SET NODE=$GET(^PXRM(809,IEN,1,INC,0))
+8 IF $PIECE(NODE,U)'["WV(790.1"
QUIT
+9 SET WVIEN=+$PIECE(NODE,U)
+10 IF $$NOOPEN(WVIEN,PAT,+BDT,+EDT)
QUIT
+11 SET WVNODE=$GET(^WV(790.1,WVIEN,0))
+12 SET ^TMP($JOB,PLIST,PAT,1)=U_$SELECT(+$PIECE(WVNODE,U,12)>0:$PIECE(WVNODE,U,12),1:DTE)_U_790.1_U_WVIEN_U
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
NONOTIFD(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
+1 NEW DAS,DTE,EPNAME,INC,NODE,NUMOPEN,PXRMARYD,WVIEN,WVNODE
+2 SET DAS=""
SET EPNAME=TEST
SET NFOUND=0
SET NUMOPEN=0
SET PXRMARYD=""
+3 IF '$DATA(^PXRM(809,"C",DFN,EPNAME))
QUIT
+4 SET DTE=0
FOR
SET DTE=$ORDER(^PXRM(809,"C",DFN,EPNAME,DTE))
if DTE'>0
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^PXRM(809,"C",DFN,EPNAME,DTE,""))
if IEN'>0
QUIT
+6 SET INC=0
FOR
SET INC=$ORDER(^PXRM(809,IEN,1,INC))
if INC'>0
QUIT
Begin DoDot:2
+7 SET NODE=$GET(^PXRM(809,IEN,1,INC,0))
+8 IF $PIECE(NODE,U)'["WV(790.1"
QUIT
+9 SET WVIEN=+$PIECE(NODE,U)
+10 IF $$NOOPEN(WVIEN,DFN,+BDT,+EDT)
QUIT
+11 SET NFOUND=NFOUND+1
+12 ;S TEST(NFOUND)=1
+13 SET WVNODE=$GET(^WV(790.1,WVIEN,0))
if WVNODE=""
QUIT
+14 SET NUMOPEN=NUMOPEN+1
+15 IF DAS[WVIEN
QUIT
+16 SET DAS=$SELECT(NUMOPEN=1:WVIEN_",",1:DAS_":"_WVIEN_",")
+17 ;D PROCDURE("",.PXRMARYD,WVIEN,.NGET,BDT,EDT,NFOUND,.TEST,.DATE,.DATA,.TEXT)
+18 ;S DATA(NFOUND,"DAS")=WVIEN_",",DATE(NFOUND)=$P(WVNODE,U,12)
+19 ;S DATA(NFOUND,"PROVIDER")=$P(WVNODE,U,7)
End DoDot:2
End DoDot:1
+20 IF DAS=""
QUIT
+21 SET NFOUND=1
+22 SET TEST(NFOUND)=1
+23 SET DATA(NFOUND,"Number of procedures with open notification")=NUMOPEN
+24 SET DATA(NFOUND,"DAS")=DAS
+25 ;S DATA(NFOUND,"Cascade Name")=EPNAME
+26 ;S DATA(NFOUND,"WV Procedure ID")=NOTID
+27 SET DATE(NFOUND)=DT
+28 SET DATA(1,"DIALOG")=1
+29 SET DATA(1,"PACKAGE")="WOMEN'S HEALTH"
+30 SET DATA(1,"PACKAGE PREFIX")="WV"
+31 SET INC=0
DO GETWVTXT(DAS,NFOUND,.INC,.TEXT)
+32 QUIT
+33 ;
OPNRPRCL(NGET,BDT,EDT,PLIST,PARAM) ;
+1 NEW BEG,END,NODE,WVIEN
+2 SET DATE=$SELECT(BDT>0:BDT,1:0)
+3 SET EDT=$SELECT(EDT<DT:EDT,1:DT)
+4 FOR
SET DATE=$ORDER(^WV(790.1,"ARADOPEN",DATE))
if DATE'>0!(DATE>EDT)
QUIT
Begin DoDot:1
+5 SET WVIEN=0
FOR
SET WVIEN=$ORDER(^WV(790.1,"ARADOPEN",DATE,WVIEN))
if WVIEN'>0
QUIT
Begin DoDot:2
+6 SET NODE=$GET(^WV(790.1,WVIEN,0))
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
COMPTERM(WVIEN,TERMLARR) ;
+1 NEW IDX,NAME,NODE,WVPIEN,WVPTYPE,RESULT,TIEN
+2 SET RESULT=0
+3 SET NODE=$GET(^WV(790.1,WVIEN,0))
+4 SET WVPIEN=$PIECE(NODE,U,4)
+5 SET TIEN=+$PIECE($GET(^WV(790.2,WVPIEN,3)),U)
IF TIEN=0
QUIT RESULT
+6 SET NAME=$PIECE($GET(^PXRMD(811.5,TIEN,0)),U)
IF NAME=""
QUIT RESULT
+7 SET IDX=0
FOR
SET IDX=$ORDER(TERMLARR(IDX))
if IDX'>0!(RESULT=1)
QUIT
Begin DoDot:1
+8 IF NAME=$GET(TERMLARR(IDX))
SET RESULT=1
End DoDot:1
+9 QUIT RESULT
+10 ;
OPENPROC(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
+1 NEW CNT,DAS,DIAGNFND,DIAGNOS,DIAGS,EPNAME,EPIEN,INC,MAX,NODE,NOTID,NUMOPEN
+2 NEW PXRMDIAG,SECDX,SECDXS,TERMLARR,TMP,WVDATE,WVDX,WVIEN,WVIENS,WVNODE,WVRPTIEN,WVSECDX
+3 SET EPNAME=TEST
SET NFOUND=0
+4 SET MAX=$$BLDTARR^PXRMPRAD(.TERMLARR)
+5 ;F X=1:1:MAX
+6 SET EPIEN=+$ORDER(^PXRM(809,"OPEN",DFN,EPNAME,""))
+7 IF EPIEN=0
QUIT
+8 SET NUMOPEN=0
SET DIAGNFND=0
+9 SET INC=0
FOR
SET INC=$ORDER(^PXRM(809,EPIEN,1,INC))
if INC'>0
QUIT
Begin DoDot:1
+10 KILL WDX
+11 SET NODE=$GET(^PXRM(809,EPIEN,1,INC,0))
+12 IF $PIECE(NODE,U)'["WV(790.1"
QUIT
+13 SET WVIEN=+$PIECE(NODE,U)
+14 SET WVNODE=$GET(^WV(790.1,WVIEN,0))
+15 IF $PIECE(WVNODE,U,12)<BDT
QUIT
+16 IF $PIECE(WVNODE,U,15)=""
QUIT
+17 IF $PIECE(WVNODE,U,14)="c"
QUIT
+18 IF '$$COMPTERM(WVIEN,.TERMLARR)
QUIT
+19 KILL WVSECDX,WVIENS,WVRPTIEN
+20 DO RADCASE^WVALERTR(WVIEN,.WVSECDX,.WVIENS,.WVRPTIEN)
+21 IF +$GET(WVRPTIEN)=0
QUIT
+22 SET CNT=0
FOR
SET CNT=$ORDER(WVSECDX("S",CNT))
if CNT'>0
QUIT
Begin DoDot:2
+23 SET SECDXS(WVSECDX("S",CNT))=""
End DoDot:2
+24 SET NUMOPEN=NUMOPEN+1
+25 SET DAS=$SELECT(NUMOPEN=1:WVIEN_",",1:DAS_":"_WVIEN_",")
+26 SET NOTID=$SELECT(NUMOPEN=1:WVIEN,1:NOTID_":"_WVIEN)
+27 SET WVDATE=$PIECE(WVNODE,U,12)
+28 IF +$PIECE(WVNODE,U,5)>0
Begin DoDot:2
+29 SET WDX=$PIECE($GET(^WV(790.31,+$PIECE(WVNODE,U,5),0)),U)
+30 IF WDX=""
SET DIAGNFND=1
+31 SET DIAGS(WDX)=""
End DoDot:2
QUIT
+32 SET DIAGNFND=1
End DoDot:1
+33 IF NUMOPEN=0
QUIT
+34 IF $GET(DAS)=""
QUIT
+35 SET NFOUND=NFOUND+1
+36 SET TEST(NFOUND)=1
+37 SET DATA(NFOUND,"Number of Test Open")=NUMOPEN
+38 SET DATA(NFOUND,"DAS")=DAS
+39 ;S DATA(NFOUND,"Cascade Name")=EPNAME
+40 ;S DATA(NFOUND,"WV Procedure ID")=NOTID
+41 SET DATE(NFOUND)=DT
+42 SET DATA(1,"DIALOG")=1
+43 SET DATA(1,"PACKAGE")="WOMEN'S HEALTH"
+44 SET DATA(1,"PACKAGE PREFIX")="WV"
+45 SET INC=0
DO GETWVTXT(DAS,NFOUND,.INC,.TEXT)
+46 SET SECDX=""
SET INC=0
FOR
SET SECDX=$ORDER(SECDXS(SECDX))
if SECDX=""
QUIT
Begin DoDot:1
+47 SET INC=INC+1
SET DATA(NFOUND,"SECONDARY DIAGNOSIS",INC)=SECDX
End DoDot:1
+48 IF DIAGNFND=1
QUIT
+49 ;S TMP=DIAGS("P")
+50 ;I TMP'["BI-RADS" S DIAGNFND=1
+51 ;E S WDX=TMP
+52 SET TMP=""
SET WDX=""
FOR
SET TMP=$ORDER(DIAGS(TMP))
if TMP=""!(DIAGNFND=1)
QUIT
Begin DoDot:1
+53 IF TMP'["BI-RADS"
SET DIAGNFND=1
QUIT
+54 SET WDX=TMP
End DoDot:1
+55 IF WDX=""
QUIT
+56 IF DIAGNFND=1
QUIT
+57 SET DATA(NFOUND,"DIAGNOSIS")=WDX
+58 QUIT
+59 ;
PROCNNOT(ALTID,PXRMARYD,WVIEN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
+1 NEW ACCESS,DCNT,INC,NODE,PUR,PURIEN,PXRMDIAG,WNIEN
+2 SET TEST(NFOUND)=1
+3 SET INC=0
+4 DO GETTEST(WVIEN,NFOUND,.INC,.TEXT,.PXRMDIAG)
+5 SET NODE=$GET(^WV(790.1,WVIEN,0))
+6 SET ACCESS=$PIECE(NODE,U)
if ACCESS=""
QUIT
+7 SET DATA(NFOUND,"ACCESSION")=$PIECE(NODE,U)
+8 SET DATA(NFOUND,"STATUS")=$SELECT($PIECE(NODE,U,14)="c":"CLOSED",$PIECE(NODE,U,14)="o":"OPEN",1:"UNKNOWN")
+9 SET DATE(NFOUND)=$PIECE(NODE,U,12)
+10 SET INC=INC+1
SET TEXT(NFOUND,INC)=""
+11 SET INC=INC+1
SET TEXT(NFOUND,INC)="Notification Purpose(s):"
+12 SET WNIEN=0
SET DCNT=0
FOR
SET WNIEN=$ORDER(^WV(790.4,"C",ACCESS,WNIEN))
if WNIEN'>0
QUIT
Begin DoDot:1
+13 SET NODE=$GET(^WV(790.4,WNIEN,0))
if NODE=""
QUIT
+14 IF +$PIECE(NODE,U,8)>0
QUIT
+15 SET PURIEN=$PIECE(NODE,U,4)
if PURIEN'>0
QUIT
+16 SET PUR=$PIECE($GET(^WV(790.404,PURIEN,0)),U)
+17 SET INC=INC+1
SET TEXT(NFOUND,INC)=PUR
+18 SET DCNT=DCNT+1
SET DATA(NFOUND,"Notification Purpose",DCNT)=PUR
End DoDot:1
+19 SET DATA(1,"DIALOG")=1
+20 SET DATA(1,"PACKAGE")="WOMEN'S HEALTH"
+21 SET DATA(1,"PACKAGE PREFIX")="WV"
+22 SET DATA(1,"DAS")=WVIEN_","
+23 QUIT
+24 ;
PROCDURE(ALTID,PXRMARYD,WVIEN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;
+1 NEW CASE,DIAG,DTE,INC,ISFALT,NODE,PROCNAME,RESULT,Y
+2 SET ISFALT=0
+3 IF ALTID'=""
IF PXRMARYD'=""
IF WVIEN>0
SET ISFALT=1
+4 SET NODE=$GET(^WV(790.1,WVIEN,0))
+5 SET DATA(NFOUND,"DIALOG")=1
+6 SET DATA(NFOUND,"PACKAGE")="WOMEN'S HEALTH"
+7 SET DATA(NFOUND,"PACKAGE PREFIX")="WV"
+8 SET DATA(NFOUND,"DAS")=WVIEN_","
+9 SET DATA(NFOUND,"ACCESSION")=$PIECE(NODE,U)
+10 SET DATA(NFOUND,"STATUS")=$SELECT($PIECE(NODE,U,14)="c":"CLOSED",$PIECE(NODE,U,14)="I":"IN PROCESS",$PIECE(NODE,U,14)="o":"OPEN",1:"UNKNOWN")
+11 SET DATA(NFOUND,"PROVIDER")=$PIECE(NODE,U,7)
+12 SET DATE(NFOUND)=$PIECE(NODE,U,12)
+13 SET TEST(NFOUND)=1
+14 SET DIAG=$PIECE(NODE,U,5)
+15 IF +DIAG>0
SET DATA(NFOUND,"DIAGNOSIS")=$PIECE($GET(^WV(790.31,DIAG,0)),U)
+16 SET INC=0
SET INC=0
DO GETWVTXT(WVIEN,NFOUND,.INC,.TEXT)
+17 SET DATE(NFOUND)=$SELECT($PIECE(NODE,U,12)>0:$PIECE(NODE,U,12),1:DT)
+18 QUIT
+19 ;
BROVRDUE(NGET,BDT,EDT,PLIST,PARAM) ;
+1 NEW DATE,PAT,PXRMARR
+2 IF PARAM=""
QUIT
+3 DO BRNEEDS^WVRPCGF1(.PXRMARR,BDT,EDT,PARAM)
+4 SET PAT=0
FOR
SET PAT=$ORDER(PXRMARR(PAT))
if PAT'>0
QUIT
SET ^TMP($JOB,PLIST,PAT,1)=U_+$GET(PXRMARR(PAT))_U_790_U_PAT_U
+5 QUIT
+6 ;
