BUD2UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2012 2:07 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
CPT(P,BDATE,EDATE,T,F,SCEX) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
S SCEX=$G(SCEX)
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)
I F=6 S V=$P(^AUPNVCPT(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)_"^"_G
I F=7 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)_U_$$FMTE^XLFDT($$VD^APCLV(V))_U_$P($P($G(^AUPNVSIT(V,0)),U),".")
Q ""
LASTDX(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
S (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BUDTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BUDTX5="" Q "" ;not a valid taxonomy
S BUDDX4="" ;return value
S BUDDXBD=9999999-BDATE,BUDDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BUDDX1=BUDDXED-1 F S BUDDX1=$O(^AUPNVPOV("AA",P,BUDDX1)) Q:BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"") D
.S BUDDX2=0 F S BUDDX2=$O(^AUPNVPOV("AA",P,BUDDX1,BUDDX2)) Q:BUDDX2'=+BUDDX2!(BUDDX4]"") D
..S BUDDX3=$P($G(^AUPNVPOV(BUDDX2,0)),U)
..Q:BUDDX3="" ;bad xref
..Q:'$D(^ICD9(BUDDX3))
..Q:'$$ICD^ATXCHK(BUDDX3,BUDTX5,9)
..S BUDDX4=1_"^"_$P($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
..Q
.Q
Q BUDDX4
LASTDXI(P,T,BDATE,EDATE,SC) ;EP
I '$G(P) Q ""
S SC=$G(SC)
;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
NEW BUDDX1,BUDDX2,BUDDX3,BUDDX5,BUDTX5,BUDDX4,BUDDXV
S (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
;S BUDTX5=$O(^ICD9("AB",T,0)) ;get taxonomy ien
S BUDTX5=+$$CODEN^ICDCODE(T,80)
I BUDTX5'>0 Q "" ;not a valid code
S BUDDX4="" ;return value
S BUDDXBD=9999999-BDATE,BUDDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BUDDX1=BUDDXED-1 F S BUDDX1=$O(^AUPNVPOV("AA",P,BUDDX1)) Q:BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"") D
.S BUDDX2=0 F S BUDDX2=$O(^AUPNVPOV("AA",P,BUDDX1,BUDDX2)) Q:BUDDX2'=+BUDDX2!(BUDDX4]"") D
..S BUDDX3=$P($G(^AUPNVPOV(BUDDX2,0)),U)
..Q:BUDDX3="" ;bad xref
..Q:BUDDX3'=BUDTX5
..S BUDDXV=$P(^AUPNVPOV(BUDDX2,0),U,3)
..I '$D(^AUPNVSIT(BUDDXV,0)) Q ;no visit entry
..I SC]"",SC'[$P(^AUPNVSIT(BUDDXV,0),U,7)
..S BUDDX4=1_"^"_$P($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
..Q
.Q
Q BUDDX4
LASTPRC(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
S (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BUDTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BUDTX5="" Q "" ;not a valid taxonomy
S BUDDX4="" ;return value
S BUDDXBD=9999999-BDATE,BUDDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BUDDX1=BUDDXED-1 F S BUDDX1=$O(^AUPNVPRC("AA",P,BUDDX1)) Q:BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"") D
.S BUDDX2=0 F S BUDDX2=$O(^AUPNVPRC("AA",P,BUDDX1,BUDDX2)) Q:BUDDX2'=+BUDDX2!(BUDDX4]"") D
..S BUDDX3=$P($G(^AUPNVPRC(BUDDX2,0)),U)
..Q:BUDDX3="" ;bad xref
..Q:'$$ICD^ATXCHK(BUDDX3,BUDTX5,0)
..S BUDDX4=1_"^"_$P($$ICDOP^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
..Q
.Q
Q BUDDX4
;
LASTPRCI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
S (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
;S BUDTX5=$O(^ICD0("AB",T,0)) ;get ICD PROC ien
S BUDTX5=+$$CODEN^ICDCODE(T,80.1)
I BUDTX5'>0 Q "" ;not a valid PROC
S BUDDX4="" ;return value
S BUDDXBD=9999999-BDATE,BUDDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BUDDX1=BUDDXED-1 F S BUDDX1=$O(^AUPNVPRC("AA",P,BUDDX1)) Q:BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"") D
.S BUDDX2=0 F S BUDDX2=$O(^AUPNVPRC("AA",P,BUDDX1,BUDDX2)) Q:BUDDX2'=+BUDDX2!(BUDDX4]"") D
..S BUDDX3=$P($G(^AUPNVPRC(BUDDX2,0)),U)
..Q:BUDDX3="" ;bad xref
..Q:BUDTX5'=BUDDX3
..S BUDDX4=1_"^"_$P($$ICDOP^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
..Q
.Q
Q BUDDX4
FIRSTPRC(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
S (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BUDTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BUDTX5="" Q "" ;not a valid taxonomy
S BUDDX4="" ;return value
S BUDX=0 F S BUDX=$O(^AUPNVPRC("AC",P,BUDX)) Q:BUDX'=+BUDX!(BUDDX4]"") D
.S BUDDX3=$P($G(^AUPNVPRC(BUDX,0)),U)
.Q:BUDDX3="" ;BAD XREF
.Q:'$$ICD^ATXCHK(BUDDX3,BUDTX5,0)
.S D=$P(^AUPNVPRC(BUDX,0),U,3)
.Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BUDDX4=1_"^"_$P($$ICDOP^ICDCODE(BUDDX3),U,2)_"^"_D_"^"_BUDDX3_"^"_BUDX
.Q
Q BUDDX4
NMIREF(P,F,I,B,E) ;EP
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) D
.S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
REFUSAL(P,F,I,B,E) ;EP
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
REFRNU(P,F,I,B,E) ;EP
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) D
.S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y D
..S D=$P(^AUPNPREF(Y,0),U,3)
..Q:D<B
..Q:D>E
..Q:"RNU"'[$P(^AUPNPREF(Y,0),U,7)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
RADREF(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,71,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,71,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,71,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..S C=$P($G(^RAMIS(71,I,0)),U,9) Q:C=""
..Q:'$$ICD^ATXCHK(C,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
I1() ;EP
I BUDVALUE="" Q 0
I BUDINDT="E",BUDVALUE]"",BUDAGEB>64 Q 1
I BUDINDT="E",BUDVALUE]"",BUDAGEB<65 Q 0
I BUDVALUE]"" Q 1
Q 0
I12() ;EP
I BUDINDT="D",BUDD4 Q 1
I BUDINDT="D",'BUDD4 Q 0
I BUDINDT="E",(BUDD3+BUDD7) Q 1
I BUDINDT="E",'(BUDD3+BUDD7) Q 0
I (BUDD1+BUDD2+BUDD3+BUDD4+BUDD5+BUDD6+BUDD7) Q 1
Q 0
I13() ;EP
I BUDINDT="D",BUDD2 Q 1
I BUDINDT="D",'BUDD2 Q 0
I BUDINDT="E",(BUDD3+BUDD1) Q 1
I BUDINDT="E",'(BUDD3+BUDD1) Q 0
I (BUDD1+BUDD2+BUDD3) Q 1
Q 0
IA() ;EP
;TESTING ONLY
NEW X
S X=BUDN1
I BUDINDT="D",BUDD7,'X Q 1
I BUDINDT="D",BUDD7,X Q 0 ;XXXX CHANGE TO Q 0 AFTER TESTING
I BUDINDT="D",'BUDD7 Q 0
I BUDINDT="C",BUDD8,'X Q 1
I BUDINDT="C",BUDD8,X Q 0 ;XXXX CHANGE TO Q 0
I BUDINDT="C",'BUDD8 Q 0
I BUDINDT="S" I (BUDD1+BUDD2+BUDD3+BUDD4+BUDD5+BUDD6+BUDD7+BUDD8) Q $S(X:0,1:1) ;LORI **** CHANGE x:1 TO x:0 AFTER TESTING
Q 0
I17() ;EP
I 'BUDD1 Q 0
I BUDINDT="W" Q $S(BUDSEX="F":1,1:0)
Q 1
I25() ;EP
I BUDINDT="D" Q BUDDMD2
I 'BUDD1 Q 0
I BUDINDT="W" Q $S(BUDSEX="F":1,1:0)
Q 1
LASTECOD(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
S (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5,BUDDX6,BUDDX7)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BUDTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BUDTX5="" Q "" ;not a valid taxonomy
S BUDDX4="" ;return value
S BUDDXBD=9999999-BDATE,BUDDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BUDDX1=BUDDXED-1 F S BUDDX1=$O(^AUPNVPOV("AA",P,BUDDX1)) Q:BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"") D
.S BUDDX2=0 F S BUDDX2=$O(^AUPNVPOV("AA",P,BUDDX1,BUDDX2)) Q:BUDDX2'=+BUDDX2!(BUDDX4]"") D
..F BUDDX6=9,18,19 S BUDDX3=$P($G(^AUPNVPOV(BUDDX2,0)),U,BUDDX6) D
...Q:BUDDX3="" ;no ecode
...I $$ICD^ATXCHK(BUDDX3,BUDTX5,9) S BUDDX4=1_"^"_$P($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
..Q
.Q
Q BUDDX4
REFTAX(P,F,T,B,E) ;EP - refused an item in a taxonomy
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(T) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT,T1 S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S T1=0,G="" F S T1=$O(^ATXAX(T,21,"B",T1)) Q:T1=""!(G) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,T1,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,T1,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,81,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..Q:'$$ICD^ATXCHK(I,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
PRCREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,80.1,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,80.1,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,80.1,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..Q:'$$ICD^ATXCHK(I,T,0)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
BUD2UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2012 2:07 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
CPT(P,BDATE,EDATE,T,F,SCEX) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 SET SCEX=$GET(SCEX)
+5 IF $GET(EDATE)=""
QUIT ""
+6 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+7 ;go through visits in a date range for this patient, check cpts
+8 NEW D,BD,ED,X,Y,D,G,V
+9 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+10 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+11 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+14 IF SCEX]""
IF SCEX[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+16 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF 'G
QUIT ""
+21 IF F=1
QUIT $SELECT(G:1,1:"")
+22 IF F=2
QUIT G
+23 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+24 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+25 IF F=5
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)
+26 IF F=6
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)_"^"_G
+27 IF F=7
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)_U_$$FMTE^XLFDT($$VD^APCLV(V))_U_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+28 QUIT ""
LASTDX(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 SET (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BUDTX5=$ORDER(^ATXAX("B",T,0))
+7 ;not a valid taxonomy
IF BUDTX5=""
QUIT ""
+8 ;return value
SET BUDDX4=""
+9 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BUDDXBD=9999999-BDATE
SET BUDDXED=9999999-EDATE
+10 SET BUDDX1=BUDDXED-1
FOR
SET BUDDX1=$ORDER(^AUPNVPOV("AA",P,BUDDX1))
IF BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"")
QUIT
Begin DoDot:1
+11 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AUPNVPOV("AA",P,BUDDX1,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4]"")
QUIT
Begin DoDot:2
+12 SET BUDDX3=$PIECE($GET(^AUPNVPOV(BUDDX2,0)),U)
+13 ;bad xref
IF BUDDX3=""
QUIT
+14 IF '$DATA(^ICD9(BUDDX3))
QUIT
+15 IF '$$ICD^ATXCHK(BUDDX3,BUDTX5,9)
QUIT
+16 SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT BUDDX4
LASTDXI(P,T,BDATE,EDATE,SC) ;EP
+1 IF '$GET(P)
QUIT ""
+2 SET SC=$GET(SC)
+3 ;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+4 NEW BUDDX1,BUDDX2,BUDDX3,BUDDX5,BUDTX5,BUDDX4,BUDDXV
+5 SET (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
+6 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+7 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+8 ;S BUDTX5=$O(^ICD9("AB",T,0)) ;get taxonomy ien
+9 SET BUDTX5=+$$CODEN^ICDCODE(T,80)
+10 ;not a valid code
IF BUDTX5'>0
QUIT ""
+11 ;return value
SET BUDDX4=""
+12 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BUDDXBD=9999999-BDATE
SET BUDDXED=9999999-EDATE
+13 SET BUDDX1=BUDDXED-1
FOR
SET BUDDX1=$ORDER(^AUPNVPOV("AA",P,BUDDX1))
IF BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"")
QUIT
Begin DoDot:1
+14 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AUPNVPOV("AA",P,BUDDX1,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4]"")
QUIT
Begin DoDot:2
+15 SET BUDDX3=$PIECE($GET(^AUPNVPOV(BUDDX2,0)),U)
+16 ;bad xref
IF BUDDX3=""
QUIT
+17 IF BUDDX3'=BUDTX5
QUIT
+18 SET BUDDXV=$PIECE(^AUPNVPOV(BUDDX2,0),U,3)
+19 ;no visit entry
IF '$DATA(^AUPNVSIT(BUDDXV,0))
QUIT
+20 IF SC]""
IF SC'[$PIECE(^AUPNVSIT(BUDDXV,0),U,7)
+21 SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT BUDDX4
LASTPRC(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 SET (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BUDTX5=$ORDER(^ATXAX("B",T,0))
+7 ;not a valid taxonomy
IF BUDTX5=""
QUIT ""
+8 ;return value
SET BUDDX4=""
+9 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BUDDXBD=9999999-BDATE
SET BUDDXED=9999999-EDATE
+10 SET BUDDX1=BUDDXED-1
FOR
SET BUDDX1=$ORDER(^AUPNVPRC("AA",P,BUDDX1))
IF BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"")
QUIT
Begin DoDot:1
+11 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AUPNVPRC("AA",P,BUDDX1,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4]"")
QUIT
Begin DoDot:2
+12 SET BUDDX3=$PIECE($GET(^AUPNVPRC(BUDDX2,0)),U)
+13 ;bad xref
IF BUDDX3=""
QUIT
+14 IF '$$ICD^ATXCHK(BUDDX3,BUDTX5,0)
QUIT
+15 SET BUDDX4=1_"^"_$PIECE($$ICDOP^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT BUDDX4
+19 ;
LASTPRCI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 SET (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;S BUDTX5=$O(^ICD0("AB",T,0)) ;get ICD PROC ien
+7 SET BUDTX5=+$$CODEN^ICDCODE(T,80.1)
+8 ;not a valid PROC
IF BUDTX5'>0
QUIT ""
+9 ;return value
SET BUDDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BUDDXBD=9999999-BDATE
SET BUDDXED=9999999-EDATE
+11 SET BUDDX1=BUDDXED-1
FOR
SET BUDDX1=$ORDER(^AUPNVPRC("AA",P,BUDDX1))
IF BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"")
QUIT
Begin DoDot:1
+12 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AUPNVPRC("AA",P,BUDDX1,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4]"")
QUIT
Begin DoDot:2
+13 SET BUDDX3=$PIECE($GET(^AUPNVPRC(BUDDX2,0)),U)
+14 ;bad xref
IF BUDDX3=""
QUIT
+15 IF BUDTX5'=BUDDX3
QUIT
+16 SET BUDDX4=1_"^"_$PIECE($$ICDOP^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT BUDDX4
FIRSTPRC(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 SET (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BUDTX5=$ORDER(^ATXAX("B",T,0))
+7 ;not a valid taxonomy
IF BUDTX5=""
QUIT ""
+8 ;return value
SET BUDDX4=""
+9 SET BUDX=0
FOR
SET BUDX=$ORDER(^AUPNVPRC("AC",P,BUDX))
IF BUDX'=+BUDX!(BUDDX4]"")
QUIT
Begin DoDot:1
+10 SET BUDDX3=$PIECE($GET(^AUPNVPRC(BUDX,0)),U)
+11 ;BAD XREF
IF BUDDX3=""
QUIT
+12 IF '$$ICD^ATXCHK(BUDDX3,BUDTX5,0)
QUIT
+13 SET D=$PIECE(^AUPNVPRC(BUDX,0),U,3)
+14 IF 'D
QUIT
+15 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+16 IF D<BDATE
QUIT
+17 IF D>EDATE
QUIT
+18 SET BUDDX4=1_"^"_$PIECE($$ICDOP^ICDCODE(BUDDX3),U,2)_"^"_D_"^"_BUDDX3_"^"_BUDX
+19 QUIT
End DoDot:1
+20 QUIT BUDDX4
NMIREF(P,F,I,B,E) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+11 SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
End DoDot:1
+12 QUIT G
REFUSAL(P,F,I,B,E) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
+9 QUIT G
REFRNU(P,F,I,B,E) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 SET D=$PIECE(^AUPNPREF(Y,0),U,3)
+11 IF D<B
QUIT
+12 IF D>E
QUIT
+13 IF "RNU"'[$PIECE(^AUPNPREF(Y,0),U,7)
QUIT
+14 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
End DoDot:1
+15 QUIT G
RADREF(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,71,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,71,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,71,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 SET C=$PIECE($GET(^RAMIS(71,I,0)),U,9)
IF C=""
QUIT
+10 IF '$$ICD^ATXCHK(C,T,1)
QUIT
+11 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT G
I1() ;EP
+1 IF BUDVALUE=""
QUIT 0
+2 IF BUDINDT="E"
IF BUDVALUE]""
IF BUDAGEB>64
QUIT 1
+3 IF BUDINDT="E"
IF BUDVALUE]""
IF BUDAGEB<65
QUIT 0
+4 IF BUDVALUE]""
QUIT 1
+5 QUIT 0
I12() ;EP
+1 IF BUDINDT="D"
IF BUDD4
QUIT 1
+2 IF BUDINDT="D"
IF 'BUDD4
QUIT 0
+3 IF BUDINDT="E"
IF (BUDD3+BUDD7)
QUIT 1
+4 IF BUDINDT="E"
IF '(BUDD3+BUDD7)
QUIT 0
+5 IF (BUDD1+BUDD2+BUDD3+BUDD4+BUDD5+BUDD6+BUDD7)
QUIT 1
+6 QUIT 0
I13() ;EP
+1 IF BUDINDT="D"
IF BUDD2
QUIT 1
+2 IF BUDINDT="D"
IF 'BUDD2
QUIT 0
+3 IF BUDINDT="E"
IF (BUDD3+BUDD1)
QUIT 1
+4 IF BUDINDT="E"
IF '(BUDD3+BUDD1)
QUIT 0
+5 IF (BUDD1+BUDD2+BUDD3)
QUIT 1
+6 QUIT 0
IA() ;EP
+1 ;TESTING ONLY
+2 NEW X
+3 SET X=BUDN1
+4 IF BUDINDT="D"
IF BUDD7
IF 'X
QUIT 1
+5 ;XXXX CHANGE TO Q 0 AFTER TESTING
IF BUDINDT="D"
IF BUDD7
IF X
QUIT 0
+6 IF BUDINDT="D"
IF 'BUDD7
QUIT 0
+7 IF BUDINDT="C"
IF BUDD8
IF 'X
QUIT 1
+8 ;XXXX CHANGE TO Q 0
IF BUDINDT="C"
IF BUDD8
IF X
QUIT 0
+9 IF BUDINDT="C"
IF 'BUDD8
QUIT 0
+10 ;LORI **** CHANGE x:1 TO x:0 AFTER TESTING
IF BUDINDT="S"
IF (BUDD1+BUDD2+BUDD3+BUDD4+BUDD5+BUDD6+BUDD7+BUDD8)
QUIT $SELECT(X:0,1:1)
+11 QUIT 0
I17() ;EP
+1 IF 'BUDD1
QUIT 0
+2 IF BUDINDT="W"
QUIT $SELECT(BUDSEX="F":1,1:0)
+3 QUIT 1
I25() ;EP
+1 IF BUDINDT="D"
QUIT BUDDMD2
+2 IF 'BUDD1
QUIT 0
+3 IF BUDINDT="W"
QUIT $SELECT(BUDSEX="F":1,1:0)
+4 QUIT 1
LASTECOD(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BUDDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 SET (BUDDX1,BUDDX2,BUDDX3,BUDDX4,BUDTX5,BUDDX6,BUDDX7)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BUDTX5=$ORDER(^ATXAX("B",T,0))
+7 ;not a valid taxonomy
IF BUDTX5=""
QUIT ""
+8 ;return value
SET BUDDX4=""
+9 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BUDDXBD=9999999-BDATE
SET BUDDXED=9999999-EDATE
+10 SET BUDDX1=BUDDXED-1
FOR
SET BUDDX1=$ORDER(^AUPNVPOV("AA",P,BUDDX1))
IF BUDDX1=""!(BUDDX1>BUDDXBD)!(BUDDX4]"")
QUIT
Begin DoDot:1
+11 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AUPNVPOV("AA",P,BUDDX1,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4]"")
QUIT
Begin DoDot:2
+12 FOR BUDDX6=9,18,19
SET BUDDX3=$PIECE($GET(^AUPNVPOV(BUDDX2,0)),U,BUDDX6)
Begin DoDot:3
+13 ;no ecode
IF BUDDX3=""
QUIT
+14 IF $$ICD^ATXCHK(BUDDX3,BUDTX5,9)
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_(9999999-BUDDX1)_"^"_BUDDX3_"^"_BUDDX2
End DoDot:3
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT BUDDX4
REFTAX(P,F,T,B,E) ;EP - refused an item in a taxonomy
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(T)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT,T1
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET T1=0
SET G=""
FOR
SET T1=$ORDER(^ATXAX(T,21,"B",T1))
IF T1=""!(G)
QUIT
Begin DoDot:1
+9 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,T1,X))
IF X'=+X!(G)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,T1,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:1
+10 QUIT G
CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,81,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 IF '$$ICD^ATXCHK(I,T,1)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
PRCREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,80.1,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,80.1,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,80.1,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 IF '$$ICD^ATXCHK(I,T,0)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
