BUDEUTL2 ; IHS/CMI/LAB - utilities for BUD ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
;; PATCH 1: Correct test for Active Chart at site DUZ2. INACTREG+11
;; Also, add Street Address Line 2 aAPCLlity. STREET+0
;; Also, provide test for patient IneligiAPCLlity INELIG+0
;
;----------
DOB(DFN) ;EP
;---> Return Patient's Date of APCLrth in Fileman format.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "NO PATIENT"
Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
Q $P(^DPT(DFN,0),U,3)
;
;
;
;----------
AGE(DFN,APCLZ,APCLDT) ;EP
;---> Return Patient's Age.
;---> Parameters:
; 1 - DFN (req) IEN in PATIENT File.
; 2 - APCLZ (opt) APCLZ=1,2,3 1=years, 2=months, 3=days.
; 2 will be assumed if not passed.
; 3 - APCLDT (opt) Date on which Age should be calculated.
;
N APCLDOB,X,X1,X2 S:$G(APCLZ)="" APCLZ=2
Q:'$G(DFN) ""
S APCLDOB=$$DOB(DFN)
Q:'APCLDOB ""
S:'$G(DT) DT=$$DT^XLFDT
S:'$G(APCLDT) APCLDT=DT
Q:APCLDT<APCLDOB ""
;
;---> Age in Years.
N APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
S APCLM1=$E(APCLDOB,4,7),APCLM2=$E(APCLDT,4,7)
S APCLY1=$E(APCLDOB,1,3),APCLY2=$E(APCLDT,1,3)
S APCLAGEY=APCLY2-APCLY1 S:APCLM2<APCLM1 APCLAGEY=APCLAGEY-1
S:APCLAGEY<1 APCLAGEY="<1"
Q:APCLZ=1 APCLAGEY
;
;---> Age in Months.
S APCLD1=$E(APCLM1,3,4),APCLM1=$E(APCLM1,1,2)
S APCLD2=$E(APCLM2,3,4),APCLM2=$E(APCLM2,1,2)
S APCLAGEM=12*APCLAGEY
I APCLM2=APCLM1&(APCLD2<APCLD1) S APCLAGEM=APCLAGEM+12
I APCLM2>APCLM1 S APCLAGEM=APCLAGEM+APCLM2-APCLM1
I APCLM2<APCLM1 S APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
S:APCLD2<APCLD1 APCLAGEM=APCLAGEM-1
Q:APCLZ=2 APCLAGEM
;
;---> Age in Days.
S X1=APCLDT,X2=APCLDOB
D ^%DTC
Q X
;
;
;----------
AGEF(DFN,APCLDT) ;EP
;---> Age formatted "35 Months" or "23 Years"
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - APCLDT (opt) Date on which Age should be calculated.
;
N Y
S Y=$$AGE(DFN,2,$G(APCLDT))
Q:Y["DECEASED" Y
Q:Y["NOT BORN" Y
;
;---> If over 60 months, return years.
I Y>60 S Y=$$AGE(DFN,1,$G(APCLDT)) Q Y_$S(Y=1:"year",1:" yrs")
;
;---> If under 1 month return days.
I Y<1 S Y=$$AGE(DFN,3,$G(APCLDT)) Q Y_$S(Y=1:" day",1:" days")
;
;---> Return months
Q Y_$S(Y=1:" mth",1:" mths")
;
;
;----------
DECEASED(DFN,APCLDT) ;EP
;---> Return 1 if patient is deceased, 0 if not deceased.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
;
Q:'$G(DFN) 0
N X S X=+$G(^DPT(DFN,.35))
Q:'X 0
Q:'$G(APCLDT) 1
Q X
;
;
GETMEDS(P,BUDMBD,BUDMED,TAXM,TAXN,TAXC,BUDDNAME,BUDZ) ;EP
S TAXM=$G(TAXM)
S TAXN=$G(TAXN)
S TAXC=$G(TAXC)
K ^TMP($J,"MEDS"),BUDZ
S BUDDNAME=$G(BUDDNAME)
NEW BUDCC1,BUDINED,BUDINBD,BUDMIEN,BUDD,X,Y,T,T1,D,G
S BUDCC1=0 K BUDZ
S BUDINED=(9999999-BUDMED)-1,BUDINBD=(9999999-BUDMBD)
F S BUDINED=$O(^AUPNVMED("AA",P,BUDINED)) Q:BUDINED=""!(BUDINED>BUDINBD) D
.S BUDMIEN=0 F S BUDMIEN=$O(^AUPNVMED("AA",P,BUDINED,BUDMIEN)) Q:BUDMIEN'=+BUDMIEN D
..Q:'$D(^AUPNVMED(BUDMIEN,0))
..S BUDD=$P(^AUPNVMED(BUDMIEN,0),U)
..Q:BUDD=""
..Q:'$D(^PSDRUG(BUDD,0))
..S BUDCC1=BUDCC1+1
..S ^TMP($J,"MEDS","ORDER",(9999999-BUDINED),BUDCC1)=(9999999-BUDINED)_U_$P(^PSDRUG(BUDD,0),U)_U_$P(^PSDRUG(BUDD,0),U)_U_BUDMIEN_U_$P(^AUPNVMED(BUDMIEN,0),U,3)
;reorder
S BUDCC1=0,X=0
F S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X D
.S Y=0 F S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y D
..S BUDCC1=BUDCC1+1
..S ^TMP($J,"MEDS",BUDCC1)=^TMP($J,"MEDS","ORDER",X,Y)
K ^TMP($J,"MEDS","ORDER")
S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0))
S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0))
S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
S BUDCC1=0,X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
.S C=$P($G(^PSDRUG(D,2)),U,4)
.I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
.I C]"",T1,$D(^ATXAX(T1,21,"B",$$STRIP^XLFSTR(C,"-"))) S G=1
.I T,$D(^ATXAX(T,21,"B",D)) S G=1
.I BUDDNAME]"",$P(^PSDRUG(D,0),U)[BUDDNAME S G=1
.I TAXM="",TAXN="",TAXC="" S G=1 ;WANTS ALL MEDS
.I G=1 S BUDCC1=BUDCC1+1,BUDZ(BUDCC1)=^TMP($J,"MEDS",X)
.Q
K ^TMP($J,"MEDS")
K BUDINED,BUDINBD,BUDMBD,BUDMED,BUDD,BUDCC1,BUDDNAME
Q
HL(P,BD,ED) ;EP - was patient homeless on any day in this time period?
I '$O(^AUPNPAT(P,85,0)) Q ""
;SET UP ARRAY OF DATES OF HOMELESSNESS
NEW X,Y,Z,N,B,C,A
S X=0 F S X=$O(^AUPNPAT(P,85,"B",X)) Q:X'=+X D
.S Y=0 F S Y=$O(^AUPNPAT(P,85,"B",X,Y)) Q:Y'=+Y D
..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="" Q
..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="N" Q
..;okay is homeless until the next value of "N" or DT if none found
..S N=X,A="" F S N=$O(^AUPNPAT(P,85,"B",N)) Q:N'=+N!(A) D
...S B=0 F S B=$O(^AUPNPAT(P,85,"B",N,B)) Q:B'=+B!(A) D
....I $P($G(^AUPNPAT(P,85,B,0)),U,2)="" Q
....I $P($G(^AUPNPAT(P,85,B,0)),U,2)="Y" Q
....S A=N ;so is homeless from X TO A
..I 'A S A=DT
..S Z(X)=X_U_$$FMADD^XLFDT(A,-1)
S X=0 ;CHECK EACH ONE TO SEE IF ANY ENCOMPASS BD TO ED
S Y=0 F S Y=$O(Z(Y)) Q:Y'=+Y D
.S B=$P(Z(Y),U,1)
.S E=$P(Z(Y),U,2)
.Q:B>ED ;begins after end date of report period
.Q:E<BD ;ends before report period
.S X=1
Q X
ALLCPT(P,BD,ED,T,A) ;EP - ALL CPTS IN A DATE RANGE IN TAXONOMY T
;P - patient
;BD - beginning date
;ED - ending date
;T - taxonomy IEN
;return all CPTSthat match in array A
;FORMAT: 1^DATE^CPT CODE EXTERNAL^V CPT IEN^VISIT IEN
S T=$G(T)
I 'T Q
NEW D,V,G,X,J,B,E,BUDC,CPTTAX
;UNFOLD TAXONOMY
D BLDTAX^ATXAPI($P(^ATXAX(T,0),U,1),"CPTTAX",T,"")
S BUDC=0
S J=0 F S J=$O(CPTTAX(J)) Q:J="" D
.S B=9999999-BD,E=9999999-ED ;get inverse date and begin at edate-1 and end when greater than begin date
.S D=E-1,D=D_".9999" S G=0 F S D=$O(^AUPNVCPT("AA",P,J,D)) Q:D'=+D!($P(D,".")>B) D
..S X=0 F S X=$O(^AUPNVCPT("AA",P,J,D,X)) Q:X'=+X D
...S BUDC=BUDC+1
...S @A@(BUDC)=(9999999-$P(D,"."))_"^"_$P(CPTTAX(J),U,1)_"^"_X_"^"_$P($G(^AUPNVCPT(X,0)),U,3)
...Q
..Q
.Q
Q
BUDEUTL2 ; IHS/CMI/LAB - utilities for BUD ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
+4 ;; PATCH 1: Correct test for Active Chart at site DUZ2. INACTREG+11
+5 ;; Also, add Street Address Line 2 aAPCLlity. STREET+0
+6 ;; Also, provide test for patient IneligiAPCLlity INELIG+0
+7 ;
+8 ;----------
DOB(DFN) ;EP
+1 ;---> Return Patient's Date of APCLrth in Fileman format.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$PIECE($GET(^DPT(DFN,0)),U,3)
QUIT "NOT ENTERED"
+7 QUIT $PIECE(^DPT(DFN,0),U,3)
+8 ;
+9 ;
+10 ;
+11 ;----------
AGE(DFN,APCLZ,APCLDT) ;EP
+1 ;---> Return Patient's Age.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) IEN in PATIENT File.
+4 ; 2 - APCLZ (opt) APCLZ=1,2,3 1=years, 2=months, 3=days.
+5 ; 2 will be assumed if not passed.
+6 ; 3 - APCLDT (opt) Date on which Age should be calculated.
+7 ;
+8 NEW APCLDOB,X,X1,X2
IF $GET(APCLZ)=""
SET APCLZ=2
+9 IF '$GET(DFN)
QUIT ""
+10 SET APCLDOB=$$DOB(DFN)
+11 IF 'APCLDOB
QUIT ""
+12 IF '$GET(DT)
SET DT=$$DT^XLFDT
+13 IF '$GET(APCLDT)
SET APCLDT=DT
+14 IF APCLDT<APCLDOB
QUIT ""
+15 ;
+16 ;---> Age in Years.
+17 NEW APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
+18 SET APCLM1=$EXTRACT(APCLDOB,4,7)
SET APCLM2=$EXTRACT(APCLDT,4,7)
+19 SET APCLY1=$EXTRACT(APCLDOB,1,3)
SET APCLY2=$EXTRACT(APCLDT,1,3)
+20 SET APCLAGEY=APCLY2-APCLY1
IF APCLM2<APCLM1
SET APCLAGEY=APCLAGEY-1
+21 IF APCLAGEY<1
SET APCLAGEY="<1"
+22 IF APCLZ=1
QUIT APCLAGEY
+23 ;
+24 ;---> Age in Months.
+25 SET APCLD1=$EXTRACT(APCLM1,3,4)
SET APCLM1=$EXTRACT(APCLM1,1,2)
+26 SET APCLD2=$EXTRACT(APCLM2,3,4)
SET APCLM2=$EXTRACT(APCLM2,1,2)
+27 SET APCLAGEM=12*APCLAGEY
+28 IF APCLM2=APCLM1&(APCLD2<APCLD1)
SET APCLAGEM=APCLAGEM+12
+29 IF APCLM2>APCLM1
SET APCLAGEM=APCLAGEM+APCLM2-APCLM1
+30 IF APCLM2<APCLM1
SET APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
+31 IF APCLD2<APCLD1
SET APCLAGEM=APCLAGEM-1
+32 IF APCLZ=2
QUIT APCLAGEM
+33 ;
+34 ;---> Age in Days.
+35 SET X1=APCLDT
SET X2=APCLDOB
+36 DO ^%DTC
+37 QUIT X
+38 ;
+39 ;
+40 ;----------
AGEF(DFN,APCLDT) ;EP
+1 ;---> Age formatted "35 Months" or "23 Years"
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - APCLDT (opt) Date on which Age should be calculated.
+5 ;
+6 NEW Y
+7 SET Y=$$AGE(DFN,2,$GET(APCLDT))
+8 IF Y["DECEASED"
QUIT Y
+9 IF Y["NOT BORN"
QUIT Y
+10 ;
+11 ;---> If over 60 months, return years.
+12 IF Y>60
SET Y=$$AGE(DFN,1,$GET(APCLDT))
QUIT Y_$SELECT(Y=1:"year",1:" yrs")
+13 ;
+14 ;---> If under 1 month return days.
+15 IF Y<1
SET Y=$$AGE(DFN,3,$GET(APCLDT))
QUIT Y_$SELECT(Y=1:" day",1:" days")
+16 ;
+17 ;---> Return months
+18 QUIT Y_$SELECT(Y=1:" mth",1:" mths")
+19 ;
+20 ;
+21 ;----------
DECEASED(DFN,APCLDT) ;EP
+1 ;---> Return 1 if patient is deceased, 0 if not deceased.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
+5 ;
+6 IF '$GET(DFN)
QUIT 0
+7 NEW X
SET X=+$GET(^DPT(DFN,.35))
+8 IF 'X
QUIT 0
+9 IF '$GET(APCLDT)
QUIT 1
+10 QUIT X
+11 ;
+12 ;
GETMEDS(P,BUDMBD,BUDMED,TAXM,TAXN,TAXC,BUDDNAME,BUDZ) ;EP
+1 SET TAXM=$GET(TAXM)
+2 SET TAXN=$GET(TAXN)
+3 SET TAXC=$GET(TAXC)
+4 KILL ^TMP($JOB,"MEDS"),BUDZ
+5 SET BUDDNAME=$GET(BUDDNAME)
+6 NEW BUDCC1,BUDINED,BUDINBD,BUDMIEN,BUDD,X,Y,T,T1,D,G
+7 SET BUDCC1=0
KILL BUDZ
+8 SET BUDINED=(9999999-BUDMED)-1
SET BUDINBD=(9999999-BUDMBD)
+9 FOR
SET BUDINED=$ORDER(^AUPNVMED("AA",P,BUDINED))
IF BUDINED=""!(BUDINED>BUDINBD)
QUIT
Begin DoDot:1
+10 SET BUDMIEN=0
FOR
SET BUDMIEN=$ORDER(^AUPNVMED("AA",P,BUDINED,BUDMIEN))
IF BUDMIEN'=+BUDMIEN
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVMED(BUDMIEN,0))
QUIT
+12 SET BUDD=$PIECE(^AUPNVMED(BUDMIEN,0),U)
+13 IF BUDD=""
QUIT
+14 IF '$DATA(^PSDRUG(BUDD,0))
QUIT
+15 SET BUDCC1=BUDCC1+1
+16 SET ^TMP($JOB,"MEDS","ORDER",(9999999-BUDINED),BUDCC1)=(9999999-BUDINED)_U_$PIECE(^PSDRUG(BUDD,0),U)_U_$PIECE(^PSDRUG(BUDD,0),U)_U_BUDMIEN_U_$PIECE(^AUPNVMED(BUDMIEN,0),U,3)
End DoDot:2
End DoDot:1
+17 ;reorder
+18 SET BUDCC1=0
SET X=0
+19 FOR
SET X=$ORDER(^TMP($JOB,"MEDS","ORDER",X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"MEDS","ORDER",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+21 SET BUDCC1=BUDCC1+1
+22 SET ^TMP($JOB,"MEDS",BUDCC1)=^TMP($JOB,"MEDS","ORDER",X,Y)
End DoDot:2
End DoDot:1
+23 KILL ^TMP($JOB,"MEDS","ORDER")
+24 SET T=""
IF TAXM]""
SET T=$ORDER(^ATXAX("B",TAXM,0))
+25 SET T1=""
IF TAXN]""
SET T1=$ORDER(^ATXAX("B",TAXN,0))
+26 SET T2=""
IF TAXC]""
SET T2=$ORDER(^ATXAX("B",TAXC,0))
+27 SET BUDCC1=0
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+28 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+29 SET G=0
+30 SET D=$PIECE(^AUPNVMED(Y,0),U)
+31 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+32 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
+33 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
+34 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",C))
SET G=1
+35 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",$$STRIP^XLFSTR(C,"-")))
SET G=1
+36 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+37 IF BUDDNAME]""
IF $PIECE(^PSDRUG(D,0),U)[BUDDNAME
SET G=1
+38 ;WANTS ALL MEDS
IF TAXM=""
IF TAXN=""
IF TAXC=""
SET G=1
+39 IF G=1
SET BUDCC1=BUDCC1+1
SET BUDZ(BUDCC1)=^TMP($JOB,"MEDS",X)
+40 QUIT
End DoDot:1
+41 KILL ^TMP($JOB,"MEDS")
+42 KILL BUDINED,BUDINBD,BUDMBD,BUDMED,BUDD,BUDCC1,BUDDNAME
+43 QUIT
HL(P,BD,ED) ;EP - was patient homeless on any day in this time period?
+1 IF '$ORDER(^AUPNPAT(P,85,0))
QUIT ""
+2 ;SET UP ARRAY OF DATES OF HOMELESSNESS
+3 NEW X,Y,Z,N,B,C,A
+4 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(P,85,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,85,"B",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)=""
QUIT
+7 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)="N"
QUIT
+8 ;okay is homeless until the next value of "N" or DT if none found
+9 SET N=X
SET A=""
FOR
SET N=$ORDER(^AUPNPAT(P,85,"B",N))
IF N'=+N!(A)
QUIT
Begin DoDot:3
+10 SET B=0
FOR
SET B=$ORDER(^AUPNPAT(P,85,"B",N,B))
IF B'=+B!(A)
QUIT
Begin DoDot:4
+11 IF $PIECE($GET(^AUPNPAT(P,85,B,0)),U,2)=""
QUIT
+12 IF $PIECE($GET(^AUPNPAT(P,85,B,0)),U,2)="Y"
QUIT
+13 ;so is homeless from X TO A
SET A=N
End DoDot:4
End DoDot:3
+14 IF 'A
SET A=DT
+15 SET Z(X)=X_U_$$FMADD^XLFDT(A,-1)
End DoDot:2
End DoDot:1
+16 ;CHECK EACH ONE TO SEE IF ANY ENCOMPASS BD TO ED
SET X=0
+17 SET Y=0
FOR
SET Y=$ORDER(Z(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+18 SET B=$PIECE(Z(Y),U,1)
+19 SET E=$PIECE(Z(Y),U,2)
+20 ;begins after end date of report period
IF B>ED
QUIT
+21 ;ends before report period
IF E<BD
QUIT
+22 SET X=1
End DoDot:1
+23 QUIT X
ALLCPT(P,BD,ED,T,A) ;EP - ALL CPTS IN A DATE RANGE IN TAXONOMY T
+1 ;P - patient
+2 ;BD - beginning date
+3 ;ED - ending date
+4 ;T - taxonomy IEN
+5 ;return all CPTSthat match in array A
+6 ;FORMAT: 1^DATE^CPT CODE EXTERNAL^V CPT IEN^VISIT IEN
+7 SET T=$GET(T)
+8 IF 'T
QUIT
+9 NEW D,V,G,X,J,B,E,BUDC,CPTTAX
+10 ;UNFOLD TAXONOMY
+11 DO BLDTAX^ATXAPI($PIECE(^ATXAX(T,0),U,1),"CPTTAX",T,"")
+12 SET BUDC=0
+13 SET J=0
FOR
SET J=$ORDER(CPTTAX(J))
IF J=""
QUIT
Begin DoDot:1
+14 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+15 SET D=E-1
SET D=D_".9999"
SET G=0
FOR
SET D=$ORDER(^AUPNVCPT("AA",P,J,D))
IF D'=+D!($PIECE(D,".")>B)
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AA",P,J,D,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET BUDC=BUDC+1
+18 SET @A@(BUDC)=(9999999-$PIECE(D,"."))_"^"_$PIECE(CPTTAX(J),U,1)_"^"_X_"^"_$PIECE($GET(^AUPNVCPT(X,0)),U,3)
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
