BUDHDU ;IHS/CMI/LAB - uds utility calls;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
Q
;----------
PAUSE ;
K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
Q
;
EOJ ;
D EN^XBVK("BUD")
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;
IN6B(T) ;EP
S BUDLST2I=$O(^BUDHLST2("C",T,0))
W:$D(IOF) @IOF
W !,$$CTR($$LOC,80)
W !,$$CTR("UDS 2018",80)
W !!,$P(^BUDHLST2(BUDLST2I,0),U,1)_" (Table 6B)",!
D GENI^BUDHRP6B
D PAUSE
S X=0 F S X=$O(^BUDHLST2(BUDLST2I,11,X)) Q:X'=+X W !,^BUDHLST2(BUDLST2I,11,X,0)
W !
Q
HT6B(T) ;EP
NEW L
S L=$O(^BUDHLST2("C",T,0))
I BUDROT="P" D Q
.S X=0 F S X=$O(^BUDHLST2(L,12,X)) Q:X'=+X W !,^BUDHLST2(L,12,X,0)
I BUDROT="D" D Q
.D S()
.S X=0 F S X=$O(^BUDHLST2(L,12,X)) Q:X'=+X D S(^BUDHLST2(L,12,X,0))
.D S()
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
;
DEMO(P,T) ;EP - exclude demo patients
I $G(P)="" Q 0
I $G(T)="" S T="I"
I T="I" Q 0
NEW R
S R=""
I T="E" D Q R
.I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=1 Q
.I $P(^DPT(DFN,0),U,1)="PATIENT,CRS" S R=1 Q
.I $P(^DPT(DFN,0),U,1)="PATIENT,UDS" S R=1 Q
.I $P(^DPT(DFN,0),U,1)="PATIENT,DEMO" S R=1 Q
.NEW %
.S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
.I '% S R=0 Q
.I $D(^DIBT(%,1,P)) S R=1 Q
I T="O" D Q R
.I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=0 Q
.NEW %
.S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
.I '% S R=1 Q
.I $D(^DIBT(%,1,P)) S R=0 Q
.S R=1 Q
Q 0
WH(P,BDATE,EDATE,T,F) ;EP
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through procedures in a date range for this patient, check proc type
NEW D,X,Y,G,V,O
S (G,V)=0,I="" F S V=$O(^BWPCD("C",P,V)) Q:V="" D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.S I=$O(G(0)) I I>D Q
.S G=V,G(D)=""
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
Q ""
PLCODE(P,A,ED,S) ;EP
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(ED)="" S ED=DT
S S=$G(S)
N T
;S T=$O(^ICD9("AB",A,0))
S T=+$$CODEN^ICDEX(A,80)
I T'>0 Q ""
N X,Y,I,A,D,G S (X,Y)=0,I="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I S Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P($G(^AUPNPROB(X,0)),U,1)
.Q:Y'=T
.S A=0,D="",G="" F S A=$O(^AUPNPROB(X,14,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,14,A,0),U,1))
..I D'>ED S G=1 ;GOOD DATE
.I 'G S A=0,D="" F S A=$O(^AUPNPROB(X,15,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,15,A,0),U,1))
..I D'>ED S G=1
.I 'G Q:$P(^AUPNPROB(X,0),U,8)>ED
.S I=1_U_$$VAL^XBDIQ1(9000011,X,.01)_U_$P(^AUPNPROB(X,0),U,3)
Q I
PLTAX(P,A) ;EP - is DX on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
N T S T=$O(^ATXAX("B",A,0))
I 'T Q ""
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D",$P(^AUPNPROB(X,0),U,12)'="I" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=1_U_$$VAL^XBDIQ1(9000011,X,.01)
Q I
PLCL(P,A,ED,S,BD) ;EP - is DX on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(S)="" S S=0
I $G(ED)="" S ED=DT
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
N T,N S T=$O(^BUDHTSSC("B",A,0))
I 'T Q ""
N X,Y,I,A,D,G S (X,Y)=0,I="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I S Q:$P(^AUPNPROB(X,0),U,12)="I"
.S A=0,D="",G="" F S A=$O(^AUPNPROB(X,14,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,14,A,0),U,1))
..I D'>ED,D'<BD S G=1 ;GOOD DATE
.I 'G S A=0,D="" F S A=$O(^AUPNPROB(X,15,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,15,A,0),U,1))
..I D'>ED,D'<BD S G=1
.I 'G I $P(^AUPNPROB(X,0),U,8)>ED!($P(^AUPNPROB(X,0),U,8)<BD) Q
.S Y=$P(^AUPNPROB(X,0),U) I $D(^BUDHTSSC("AD",Y,T)) S I=1_U_$$VAL^XBDIQ1(9000011,X,.01)_U_$P(^AUPNPROB(X,0),U,3) Q
.S N=$$VAL^XBDIQ1(9000011,X,80001) I N]"",$D(^BUDHTSSC("AS",N,T)) S I=1_U_N_U_$P(^AUPNPROB(X,0),U,3)
Q I
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_"^"_V
Q ""
RAD(P,BDATE,EDATE,T,F) ;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
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,C
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(^AUPNVRAD("AD",V))
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
...S C=$P(^AUPNVRAD(X,0),U) Q:C="" S C=$P($G(^RAMIS(71,C,0)),U,9) Q:C=""
...I $$ICD^ATXCHK(C,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(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U,9)
I F=6 S V=$P(^AUPNVRAD(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U)_"^"_G
Q ""
CPTI(P,BDATE,EDATE,CPTI,SCEX,SCLN,SMOD) ;EP - did patient have this cpt (ien) in date range
I '$G(P) Q ""
I $G(CPTI)="" Q ""
I $G(BDATE)="" Q ""
I $G(EDATE)="" Q ""
S SCEX=$G(SCEX)
S SCLN=$G(SCLN)
S SMOD=$G(SMOD)
I '$D(^ICPT(CPTI)) Q "" ;not a valid cpt ien
I '$D(^AUPNVCPT("AA",P)) Q "" ;no cpts for this patient
NEW D,BD,ED,X,Y,D,G,V,I,M,M1,Z,J,K,Q,Z
S ED=9999999-EDATE-1,BD=9999999-BDATE,G=""
F S ED=$O(^AUPNVCPT("AA",P,CPTI,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S I=0 F S I=$O(^AUPNVCPT("AA",P,CPTI,ED,I)) Q:I'=+I!(G) D
..S V=$P($G(^AUPNVCPT(I,0)),U,3)
..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
..I SCLN]"",$$CLINIC^APCLV(V,"C")=SCLN Q
..S M=$$VAL^XBDIQ1(9000010.18,I,.08)
..S M1=$$VAL^XBDIQ1(9000010.18,I,.09)
..S Q=0
..I SMOD]"" F J=1:1 S K=$P(SMOD,";",J) Q:K="" I K=M S Q=1
..Q:Q
..I SMOD]"" F J=1:1 S K=$P(SMOD,";",J) Q:K="" I K=M1 S Q=1
..Q:Q
..S G="1"_"^"_(9999999-ED)
Q G
;
TRANI(P,BDATE,EDATE,CPTI) ;EP
I '$G(P) Q ""
I $G(TRANI)="" Q ""
I $G(BDATE)="" Q ""
I $G(EDATE)="" Q ""
I '$D(^ICPT(CPTI)) Q ""
I '$D(^AUPNVTC("AC",P)) Q "" ;no cpts for this patient
NEW X,V,C,G
S G=""
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.S C=$P($G(^AUPNVTC(X,0)),U,7)
.Q:C'=CPTI
.S V=$P(^AUPNVTC(X,0),U,3)
.S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:V<BDATE
.Q:V>EDATE
.S G="1"_"^"_V
Q G
TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
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(^AUPNVTC("AD",V))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXCHK($P(^AUPNVTC(X,0),U,7),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(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVTC(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)
I F=6 S V=$P(^AUPNVTC(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)_"^"_G_"^"_V
Q ""
;
LASTITEM(P,BD,ED,BUDT,BUDV) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
I $G(BUDT)="" Q ""
I $G(BUDV)="" Q ""
NEW BUDR,%,E,Y K R S %=P_"^LAST "_BUDT_" "_BUDV_";DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDR(")
I '$D(BUDR(1)) Q ""
Q 1_U_$P(BUDR(1),U,1)_U_$P(BUDR(1),U,3)_U_$P(BUDR(1),U,2)
;
BANNER ;EP
V ; GET VERSION
S BUD("VERSION")="2.0 January, 2003"
S BUDTEXT="TEXT",BUDLINE=3 G PRINT
F BUDJ=1:1 S BUDX=$T(@BUDTEXT+BUDJ),BUDX=$P(BUDX,";;",2) Q:BUDX="QUIT"!(BUDX="") S BUDLINE=BUDJ
PRINT W:$D(IOF) @IOF
F BUDJ=1:1:BUDLINE S BUDX=$T(@BUDTEXT+BUDJ),BUDX=$P(BUDX,";;",2) W !?80-$L(BUDX)\2,BUDX K BUDX
W !?80-(8+$L(BUD("VERSION")))/2,"Version ",BUD("VERSION")
SITE G XIT:'$D(DUZ(2)) G:'DUZ(2) XIT S BUD("SITE")=$P(^DIC(4,DUZ(2),0),"^") W !!?80-$L(BUD("SITE"))\2,BUD("SITE")
XIT ;
K BUDJ,BUDX,BUDTEXT,BUDLINE,BUD("SITE"),BUD("VERSION")
Q
PLTAXND(P,A,E,Z) ;EP - is dx on problem list as NOT DELETED
;P is dfn
;a is taxonomy name
I $G(P)="" Q ""
I $G(A)="" Q ""
S E=$G(E)
S Z=$G(Z) ;skip inactive if =1
NEW T S T=$O(^ATXAX("B",A,0))
I 'T Q "" ;bad taxonomy??
NEW X,Y,I,D
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I Z Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.I E,$P(^AUPNPROB(X,0),U,13)>E Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",E,$P(^AUPNPROB(X,0),U,8)>E Q ;entered after report period, skip
.Q:'$$ICD^ATXAPI(Y,T,9)
.S D=$P(^AUPNPROB(X,0),U,13)
.I 'D S D=$P(^AUPNPROB(X,0),U,3)
.S I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D
.Q
Q I
IPLSNOND(P,T,E,Z) ;EP - any problem list entry with a SNOMED in T
;LOOP PROBLEM LIST
NEW G,X,Y
S (X,G)=""
S E=$G(E)
S Z=$G(Z)
S T=$G(T)
S T=$O(^BUDHTSSC("B",T,0))
F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
.S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
..Q:'$D(^AUPNPROB(Y,0))
..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
..I Z Q:$P(^AUPNPROB(Y,0),U,12)="I"
..Q:'$D(^BUDHTSSC(T,13,"B",X))
..I E,$P(^AUPNPROB(Y,0),U,13)>E Q ;if there is a doo and it is after report period skip
..I $P(^AUPNPROB(Y,0),U,13)="",E,$P(^AUPNPROB(Y,0),U,8)>E Q ;entered after report period, skip
..S D=$P(^AUPNPROB(Y,0),U,13)
..I 'D S D=$P(^AUPNPROB(Y,0),U,3)
..S G=1_U_"Problem List: "_X_U_D ;$$CONCPT^AUPNVUTL(X)
Q G
BECPTS ;;
;;74270
;;74275
;;74280
;;
SIGCPTS ;;
;;45300
;;45303
;;45305
;;45307
;;45308
;;45309
;;45315
;;45317
;;45320
;;45321
;;45327
;;45330
;;45331
;;45332
;;45333
;;45334
;;45336
;;45337
;;45338
;;45339
;;45341
;;45342
;;45345
;;
COLOCPTS ;;
;;45355
;;45360
;;45361
;;45362
;;45363
;;45364
;;45365
;;45366
;;45367
;;45368
;;45369
;;45370
;;45371
;;45372
;;45378
;;45379
;;45380
;;45382
;;45383
;;45384
;;45385
;;45387
;;
BUDHDU ;IHS/CMI/LAB - uds utility calls;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
+4 ;----------
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="PRESS ENTER"
KILL DA
DO ^DIR
KILL DIR
+2 QUIT
+3 ;
EOJ ;
+1 DO EN^XBVK("BUD")
+2 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;
IN6B(T) ;EP
+1 SET BUDLST2I=$ORDER(^BUDHLST2("C",T,0))
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !,$$CTR($$LOC,80)
+4 WRITE !,$$CTR("UDS 2018",80)
+5 WRITE !!,$PIECE(^BUDHLST2(BUDLST2I,0),U,1)_" (Table 6B)",!
+6 DO GENI^BUDHRP6B
+7 DO PAUSE
+8 SET X=0
FOR
SET X=$ORDER(^BUDHLST2(BUDLST2I,11,X))
IF X'=+X
QUIT
WRITE !,^BUDHLST2(BUDLST2I,11,X,0)
+9 WRITE !
+10 QUIT
HT6B(T) ;EP
+1 NEW L
+2 SET L=$ORDER(^BUDHLST2("C",T,0))
+3 IF BUDROT="P"
Begin DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^BUDHLST2(L,12,X))
IF X'=+X
QUIT
WRITE !,^BUDHLST2(L,12,X,0)
End DoDot:1
QUIT
+5 IF BUDROT="D"
Begin DoDot:1
+6 DO S()
+7 SET X=0
FOR
SET X=$ORDER(^BUDHLST2(L,12,X))
IF X'=+X
QUIT
DO S(^BUDHLST2(L,12,X,0))
+8 DO S()
End DoDot:1
QUIT
+9 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
+4 ;
DEMO(P,T) ;EP - exclude demo patients
+1 IF $GET(P)=""
QUIT 0
+2 IF $GET(T)=""
SET T="I"
+3 IF T="I"
QUIT 0
+4 NEW R
+5 SET R=""
+6 IF T="E"
Begin DoDot:1
+7 IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"
SET R=1
QUIT
+8 IF $PIECE(^DPT(DFN,0),U,1)="PATIENT,CRS"
SET R=1
QUIT
+9 IF $PIECE(^DPT(DFN,0),U,1)="PATIENT,UDS"
SET R=1
QUIT
+10 IF $PIECE(^DPT(DFN,0),U,1)="PATIENT,DEMO"
SET R=1
QUIT
+11 NEW %
+12 SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
+13 IF '%
SET R=0
QUIT
+14 IF $DATA(^DIBT(%,1,P))
SET R=1
QUIT
End DoDot:1
QUIT R
+15 IF T="O"
Begin DoDot:1
+16 IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"
SET R=0
QUIT
+17 NEW %
+18 SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
+19 IF '%
SET R=1
QUIT
+20 IF $DATA(^DIBT(%,1,P))
SET R=0
QUIT
+21 SET R=1
QUIT
End DoDot:1
QUIT R
+22 QUIT 0
WH(P,BDATE,EDATE,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through procedures in a date range for this patient, check proc type
+7 NEW D,X,Y,G,V,O
+8 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+9 IF '$DATA(^BWPCD(V,0))
QUIT
+10 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+11 SET D=$PIECE(^BWPCD(V,0),U,12)
+12 IF D<BDATE
QUIT
+13 IF D>EDATE
QUIT
+14 SET I=$ORDER(G(0))
IF I>D
QUIT
+15 SET G=V
SET G(D)=""
+16 QUIT
End DoDot:1
+17 IF 'G
QUIT ""
+18 IF F=1
QUIT $SELECT(G:1,1:"")
+19 IF F=2
QUIT G
+20 IF F=3
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT D
+21 IF F=4
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT $$FMTE^XLFDT(D)
+22 QUIT ""
PLCODE(P,A,ED,S) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(ED)=""
SET ED=DT
+4 SET S=$GET(S)
+5 NEW T
+6 ;S T=$O(^ICD9("AB",A,0))
+7 SET T=+$$CODEN^ICDEX(A,80)
+8 IF T'>0
QUIT ""
+9 NEW X,Y,I,A,D,G
SET (X,Y)=0
SET I=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
Begin DoDot:1
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+11 IF S
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+12 SET Y=$PIECE($GET(^AUPNPROB(X,0)),U,1)
+13 IF Y'=T
QUIT
+14 SET A=0
SET D=""
SET G=""
FOR
SET A=$ORDER(^AUPNPROB(X,14,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+15 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,14,A,0),U,1))
+16 ;GOOD DATE
IF D'>ED
SET G=1
End DoDot:2
+17 IF 'G
SET A=0
SET D=""
FOR
SET A=$ORDER(^AUPNPROB(X,15,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+18 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,15,A,0),U,1))
+19 IF D'>ED
SET G=1
End DoDot:2
+20 IF 'G
IF $PIECE(^AUPNPROB(X,0),U,8)>ED
QUIT
+21 SET I=1_U_$$VAL^XBDIQ1(9000011,X,.01)_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+22 QUIT I
PLTAX(P,A) ;EP - is DX on problem list 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+4 IF 'T
QUIT ""
+5 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
IF $PIECE(^AUPNPROB(X,0),U,12)'="I"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXCHK(Y,T,9)
SET I=1_U_$$VAL^XBDIQ1(9000011,X,.01)
+6 QUIT I
PLCL(P,A,ED,S,BD) ;EP - is DX on problem list 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(S)=""
SET S=0
+4 IF $GET(ED)=""
SET ED=DT
+5 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+6 NEW T,N
SET T=$ORDER(^BUDHTSSC("B",A,0))
+7 IF 'T
QUIT ""
+8 NEW X,Y,I,A,D,G
SET (X,Y)=0
SET I=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
Begin DoDot:1
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 IF S
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+11 SET A=0
SET D=""
SET G=""
FOR
SET A=$ORDER(^AUPNPROB(X,14,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+12 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,14,A,0),U,1))
+13 ;GOOD DATE
IF D'>ED
IF D'<BD
SET G=1
End DoDot:2
+14 IF 'G
SET A=0
SET D=""
FOR
SET A=$ORDER(^AUPNPROB(X,15,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+15 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,15,A,0),U,1))
+16 IF D'>ED
IF D'<BD
SET G=1
End DoDot:2
+17 IF 'G
IF $PIECE(^AUPNPROB(X,0),U,8)>ED!($PIECE(^AUPNPROB(X,0),U,8)<BD)
QUIT
+18 SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $DATA(^BUDHTSSC("AD",Y,T))
SET I=1_U_$$VAL^XBDIQ1(9000011,X,.01)_U_$PIECE(^AUPNPROB(X,0),U,3)
QUIT
+19 SET N=$$VAL^XBDIQ1(9000011,X,80001)
IF N]""
IF $DATA(^BUDHTSSC("AS",N,T))
SET I=1_U_N_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+20 QUIT I
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_"^"_V
+27 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;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 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V,C
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 SET C=$PIECE(^AUPNVRAD(X,0),U)
IF C=""
QUIT
SET C=$PIECE($GET(^RAMIS(71,C,0)),U,9)
IF C=""
QUIT
+15 IF $$ICD^ATXCHK(C,T,1)
SET G=X
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 IF F=1
QUIT $SELECT(G:1,1:"")
+21 IF F=2
QUIT G
+22 IF F=3
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+23 IF F=4
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+24 IF F=5
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE(^RAMIS(71,$PIECE(^AUPNVRAD(G,0),U),0),U,9)
+25 IF F=6
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE(^RAMIS(71,$PIECE(^AUPNVRAD(G,0),U),0),U)_"^"_G
+26 QUIT ""
CPTI(P,BDATE,EDATE,CPTI,SCEX,SCLN,SMOD) ;EP - did patient have this cpt (ien) in date range
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(CPTI)=""
QUIT ""
+3 IF $GET(BDATE)=""
QUIT ""
+4 IF $GET(EDATE)=""
QUIT ""
+5 SET SCEX=$GET(SCEX)
+6 SET SCLN=$GET(SCLN)
+7 SET SMOD=$GET(SMOD)
+8 ;not a valid cpt ien
IF '$DATA(^ICPT(CPTI))
QUIT ""
+9 ;no cpts for this patient
IF '$DATA(^AUPNVCPT("AA",P))
QUIT ""
+10 NEW D,BD,ED,X,Y,D,G,V,I,M,M1,Z,J,K,Q,Z
+11 SET ED=9999999-EDATE-1
SET BD=9999999-BDATE
SET G=""
+12 FOR
SET ED=$ORDER(^AUPNVCPT("AA",P,CPTI,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+13 SET I=0
FOR
SET I=$ORDER(^AUPNVCPT("AA",P,CPTI,ED,I))
IF I'=+I!(G)
QUIT
Begin DoDot:2
+14 SET V=$PIECE($GET(^AUPNVCPT(I,0)),U,3)
+15 IF SCEX]""
IF SCEX[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+16 IF SCLN]""
IF $$CLINIC^APCLV(V,"C")=SCLN
QUIT
+17 SET M=$$VAL^XBDIQ1(9000010.18,I,.08)
+18 SET M1=$$VAL^XBDIQ1(9000010.18,I,.09)
+19 SET Q=0
+20 IF SMOD]""
FOR J=1:1
SET K=$PIECE(SMOD,";",J)
IF K=""
QUIT
IF K=M
SET Q=1
+21 IF Q
QUIT
+22 IF SMOD]""
FOR J=1:1
SET K=$PIECE(SMOD,";",J)
IF K=""
QUIT
IF K=M1
SET Q=1
+23 IF Q
QUIT
+24 SET G="1"_"^"_(9999999-ED)
End DoDot:2
End DoDot:1
+25 QUIT G
+26 ;
TRANI(P,BDATE,EDATE,CPTI) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(TRANI)=""
QUIT ""
+3 IF $GET(BDATE)=""
QUIT ""
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF '$DATA(^ICPT(CPTI))
QUIT ""
+6 ;no cpts for this patient
IF '$DATA(^AUPNVTC("AC",P))
QUIT ""
+7 NEW X,V,C,G
+8 SET G=""
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET C=$PIECE($GET(^AUPNVTC(X,0)),U,7)
+11 IF C'=CPTI
QUIT
+12 SET V=$PIECE(^AUPNVTC(X,0),U,3)
+13 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+14 IF V<BDATE
QUIT
+15 IF V>EDATE
QUIT
+16 SET G="1"_"^"_V
End DoDot:1
+17 QUIT G
TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVTC("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF $$ICD^ATXCHK($PIECE(^AUPNVTC(X,0),U,7),T,1)
SET G=X
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF F=4
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 IF F=5
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVTC(G,0),U,7)),U,2)
+24 IF F=6
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVTC(G,0),U,7)),U,2)_"^"_G_"^"_V
+25 QUIT ""
+26 ;
LASTITEM(P,BD,ED,BUDT,BUDV) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
+1 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+2 IF $GET(ED)=""
SET ED=DT
+3 IF $GET(BUDT)=""
QUIT ""
+4 IF $GET(BUDV)=""
QUIT ""
+5 NEW BUDR,%,E,Y
KILL R
SET %=P_"^LAST "_BUDT_" "_BUDV_";DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDR(")
+6 IF '$DATA(BUDR(1))
QUIT ""
+7 QUIT 1_U_$PIECE(BUDR(1),U,1)_U_$PIECE(BUDR(1),U,3)_U_$PIECE(BUDR(1),U,2)
+8 ;
BANNER ;EP
V ; GET VERSION
+1 SET BUD("VERSION")="2.0 January, 2003"
+2 SET BUDTEXT="TEXT"
SET BUDLINE=3
GOTO PRINT
+3 FOR BUDJ=1:1
SET BUDX=$TEXT(@BUDTEXT+BUDJ)
SET BUDX=$PIECE(BUDX,";;",2)
IF BUDX="QUIT"!(BUDX="")
QUIT
SET BUDLINE=BUDJ
PRINT IF $DATA(IOF)
WRITE @IOF
+1 FOR BUDJ=1:1:BUDLINE
SET BUDX=$TEXT(@BUDTEXT+BUDJ)
SET BUDX=$PIECE(BUDX,";;",2)
WRITE !?80-$LENGTH(BUDX)\2,BUDX
KILL BUDX
+2 WRITE !?80-(8+$LENGTH(BUD("VERSION")))/2,"Version ",BUD("VERSION")
SITE IF '$DATA(DUZ(2))
GOTO XIT
IF 'DUZ(2)
GOTO XIT
SET BUD("SITE")=$PIECE(^DIC(4,DUZ(2),0),"^")
WRITE !!?80-$LENGTH(BUD("SITE"))\2,BUD("SITE")
XIT ;
+1 KILL BUDJ,BUDX,BUDTEXT,BUDLINE,BUD("SITE"),BUD("VERSION")
+2 QUIT
PLTAXND(P,A,E,Z) ;EP - is dx on problem list as NOT DELETED
+1 ;P is dfn
+2 ;a is taxonomy name
+3 IF $GET(P)=""
QUIT ""
+4 IF $GET(A)=""
QUIT ""
+5 SET E=$GET(E)
+6 ;skip inactive if =1
SET Z=$GET(Z)
+7 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+8 ;bad taxonomy??
IF 'T
QUIT ""
+9 NEW X,Y,I,D
+10 SET (X,Y,I)=0
+11 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNPROB(X,0))
QUIT
+13 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+14 IF Z
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+15 SET Y=$PIECE(^AUPNPROB(X,0),U)
+16 ;if there is a doo and it is after report period skip
IF E
IF $PIECE(^AUPNPROB(X,0),U,13)>E
QUIT
+17 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF E
IF $PIECE(^AUPNPROB(X,0),U,8)>E
QUIT
+18 IF '$$ICD^ATXAPI(Y,T,9)
QUIT
+19 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+20 IF 'D
SET D=$PIECE(^AUPNPROB(X,0),U,3)
+21 SET I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D
+22 QUIT
End DoDot:1
+23 QUIT I
IPLSNOND(P,T,E,Z) ;EP - any problem list entry with a SNOMED in T
+1 ;LOOP PROBLEM LIST
+2 NEW G,X,Y
+3 SET (X,G)=""
+4 SET E=$GET(E)
+5 SET Z=$GET(Z)
+6 SET T=$GET(T)
+7 SET T=$ORDER(^BUDHTSSC("B",T,0))
+8 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:1
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+10 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+11 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+12 IF Z
IF $PIECE(^AUPNPROB(Y,0),U,12)="I"
QUIT
+13 IF '$DATA(^BUDHTSSC(T,13,"B",X))
QUIT
+14 ;if there is a doo and it is after report period skip
IF E
IF $PIECE(^AUPNPROB(Y,0),U,13)>E
QUIT
+15 ;entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF E
IF $PIECE(^AUPNPROB(Y,0),U,8)>E
QUIT
+16 SET D=$PIECE(^AUPNPROB(Y,0),U,13)
+17 IF 'D
SET D=$PIECE(^AUPNPROB(Y,0),U,3)
+18 ;$$CONCPT^AUPNVUTL(X)
SET G=1_U_"Problem List: "_X_U_D
End DoDot:2
End DoDot:1
+19 QUIT G
BECPTS ;;
+1 ;;74270
+2 ;;74275
+3 ;;74280
+4 ;;
SIGCPTS ;;
+1 ;;45300
+2 ;;45303
+3 ;;45305
+4 ;;45307
+5 ;;45308
+6 ;;45309
+7 ;;45315
+8 ;;45317
+9 ;;45320
+10 ;;45321
+11 ;;45327
+12 ;;45330
+13 ;;45331
+14 ;;45332
+15 ;;45333
+16 ;;45334
+17 ;;45336
+18 ;;45337
+19 ;;45338
+20 ;;45339
+21 ;;45341
+22 ;;45342
+23 ;;45345
+24 ;;
COLOCPTS ;;
+1 ;;45355
+2 ;;45360
+3 ;;45361
+4 ;;45362
+5 ;;45363
+6 ;;45364
+7 ;;45365
+8 ;;45366
+9 ;;45367
+10 ;;45368
+11 ;;45369
+12 ;;45370
+13 ;;45371
+14 ;;45372
+15 ;;45378
+16 ;;45379
+17 ;;45380
+18 ;;45382
+19 ;;45383
+20 ;;45384
+21 ;;45385
+22 ;;45387
+23 ;;
