APCLVLU1 ; IHS/CMI/LAB - GEN RETR UTILITIES ; 27 Aug 2014 10:52 AM
;;2.0;IHS PCC SUITE;**2,4,5,7,11,20,21**;MAY 14, 2009;Build 34
RACESCR ;
NEW Y,Z
K Z
D LIST^DIC(2.02,","_DFN_",","@;.01E","P",,,,,,,"Z")
S Y=0 F S Y=$O(Z("DILIST",Y)) Q:Y="" S X($P(Z("DILIST",Y,0),U,1))=""
Q
RACEPRT ;
NEW Z,Y
D LIST^DIC(2.02,","_DFN_",","@;.01E","P",,,,,,,"Z")
S Y=0 F S Y=$O(Z("DILIST",Y)) Q:Y="" D
.;S APCLPCNT=APCLPCNT+1
.S X($P(Z("DILIST",Y,0),U,1))=""
.S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=$P(Z("DILIST",Y,0),U,2)
.S APCLPRNM(APCLPCNT,"I")=$P(Z("DILIST",Y,0),U,1)
.Q
Q
MCR ;MCR display all current medicare data
NEW APCLMIFN
I '$D(^DPT(P,0)) G MCRX
I $P(^DPT(P,0),U,19) G MCRX
I '$D(^AUPNPAT(P,0)) G MCRX
I '$D(^AUPNMCR(P,11)) G MCRX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
S APCLMIFN=0 F S APCLMIFN=$O(^AUPNMCR(P,11,APCLMIFN)) Q:APCLMIFN'=+APCLMIFN D
.Q:$P(^AUPNMCR(P,11,APCLMIFN,0),U)>D
.I $P(^AUPNMCR(P,11,APCLMIFN,0),U,2)]"",$P(^(0),U,2)<D Q
.S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=$$GETMCR^AGUTL(P)_" ["_$S($P(^AUPNMCR(P,0),U,4)]"":$P(^AUTTMCS($P(^AUPNMCR(P,0),U,4),0),U),1:"-")_"]" ;IHS/CMI/LAB PATCH 21 NMCI
.S APCLPCNT=APCLPCNT+1,Y=$P(^AUPNMCR(DFN,11,APCLMIFN,0),U),Z=$P(^(0),U,2),APCLPRNM(APCLPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S APCLPRNM(APCLPCNT)=APCLPRNM(APCLPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)
.Q
MCRX ;
K Y,Z
Q
;
MCD ;EP
NEW APCLMIFN,APCLNIFN
I '$D(^DPT(P,0)) G MCDX
I $P(^DPT(P,0),U,19) G MCDX
I '$D(^AUPNPAT(P,0)) G MCDX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX
S APCLMIFN=0 F S APCLMIFN=$O(^AUPNMCD("B",P,APCLMIFN)) Q:APCLMIFN'=+APCLMIFN D
.Q:'$D(^AUPNMCD(APCLMIFN,11))
.S APCLNIFN=0 F S APCLNIFN=$O(^AUPNMCD(APCLMIFN,11,APCLNIFN)) Q:APCLNIFN'=+APCLNIFN D
..Q:APCLNIFN>D
..I $P(^AUPNMCD(APCLMIFN,11,APCLNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
..S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=$P(^AUPNMCD(APCLMIFN,0),U,3)_"/"_$S($P(^AUPNMCD(APCLMIFN,0),U,2)]"":$P(^AUTNINS($P(^AUPNMCD(APCLMIFN,0),U,2),0),U),1:"<>")
..S APCLPCNT=APCLPCNT+1,Y=$P(^AUPNMCD(APCLMIFN,11,APCLNIFN,0),U),Z=$P(^(0),U,2),APCLPRNM(APCLPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S APCLPRNM(APCLPCNT)=APCLPRNM(APCLPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)
..Q
.Q
;
MCDX ;
Q
;
PI ;EP
NEW APCLMIFN,APCLFLG
I '$D(^DPT(P,0)) G PIX
I $P(^DPT(P,0),U,19) G PIX
I '$D(^AUPNPAT(P,0)) G PIX
I '$D(^AUPNPRVT(P,11)) G PIX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
S APCLMIFN=0 F S APCLMIFN=$O(^AUPNPRVT(P,11,APCLMIFN)) Q:APCLMIFN'=+APCLMIFN D
.Q:$P(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
.S APCLNAME=$P(^AUPNPRVT(DFN,11,APCLMIFN,0),U) Q:APCLNAME=""
.Q:$P(^AUTNINS(APCLNAME,0),U)["AHCCCS"
.Q:$P(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
.I $P(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
.S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=$P(^AUTNINS($P(^AUPNPRVT(P,11,APCLMIFN,0),U),0),U)
.S APCLPCNT=APCLPCNT+1,Y=$P(^AUPNPRVT(DFN,11,APCLMIFN,0),U,6),Z=$P(^(0),U,7),APCLPRNM(APCLPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S APCLPRNM(APCLPCNT)=APCLPRNM(APCLPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)
.Q
PIX ;
Q
PIV ;EP
NEW APCLMIFN,APCLFLG
I '$D(^DPT(P,0)) G PIX
I $P(^DPT(P,0),U,19) G PIX
I '$D(^AUPNPAT(P,0)) G PIX
I '$D(^AUPNPRVT(P,11)) G PIX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
S APCLMIFN=0 F S APCLMIFN=$O(^AUPNPRVT(P,11,APCLMIFN)) Q:APCLMIFN'=+APCLMIFN D
.Q:$P(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
.S APCLNAME=$P(^AUPNPRVT(DFN,11,APCLMIFN,0),U) Q:APCLNAME=""
.Q:$P(^AUTNINS(APCLNAME,0),U)["AHCCCS"
.Q:$P(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
.I $P(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
.S APCLPRNT=$P(^AUPNPRVT(P,11,APCLMIFN,0),U,9) I APCLPRNT]"" S APCLPRNT=$$FMTE^XLFDT(APCLPRNT,"2D")
.Q
PIVX ;
Q
;
ML ;EP - set up mailing address print array
S APCLPCNT=0 K APCLPRNM
F X=1:1:3 S Y=$P($G(^DPT(DFN,.11)),U,X) I Y]"" S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=Y
S X=$P($G(^DPT(DFN,.11)),U,4)_", "
S Y="",Y=$P($G(^DPT(DFN,.11)),U,5) I Y S Y=$P(^DIC(5,Y,0),U)
S X=X_$S(Y]"":Y,1:" ")
S X=X_" "_$P($G(^DPT(DFN,.11)),U,6)
S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=X
Q
;
BILLNUM(V) ;EP - given visit ien (V), return bill #
;from ABMDBILL
I '$G(V) Q ""
I '$D(^AUPNVSIT(V)) Q ""
NEW D,X,B
S (D,X)=0,B="" F S D=$O(^ABMDBILL(D)) Q:D'=+D D
.S X=0 F S X=$O(^ABMDBILL(D,"AV",V,X)) Q:X'=+X S B=$P(^ABMDBILL(D,X,0),"^")
.Q
Q B
;
PSCLS ;EP
S A=0 F S A=$O(^AUPNVPRV("AD",APCLVIEN,A)) Q:A'=+A S P=$P(^AUPNVPRV(A,0),U),Z=$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(P),1:$P(^DIC(7,$P(^DIC(6,P,0),U,4),0),U)) D
.S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=Z
.S APCLPRNM(APCLPCNT,"I")=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,"PS")),U,5),1:$P(^DIC(6,P,0),U,4))
.Q
Q
PSAFFL ;
S A=0 F S A=$O(^AUPNVPRV("AD",APCLVIEN,A)) Q:A'=+A S P=$P(^AUPNVPRV(A,0),U),Z=$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVAFFL^XBFUNC1(P),1:$P($G(^DIC(6,P,9999999)),U)) D
.S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=Z
.S APCLPRNM(APCLPCNT,"I")=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,9999999)),U,1),1:$P($G(^DIC(6,P,9999999)),U))
.Q
Q
EDPD ;EP
N AY,P S AY=0 F S AY=$O(^AUPNVPED("AD",APCLVIEN,AY)) Q:AY'=+AY S P=$P(^AUPNVPED(AY,0),U,5) I P D
.S Z=$S($P(^DD(9000010.16,.05,0),U,2)[200:$$PROVCLS^XBFUNC1(P),1:$P(^DIC(7,$P(^DIC(6,P,0),U,4),0),U)) S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=Z
.S APCLPRNM(APCLPCNT,"I")=$S($P(^DD(9000010.16,.05,0),U,2)[200:$P($G(^VA(200,P,"PS")),U,5),1:$P($G(^DIC(6,P,0)),U,4))
Q
LABLOINC ;
NEW A,B,C,D,J
K X
S A=0
S APCLSPEC=""
F S A=$O(^AUPNVLAB("AD",APCLVIEN,A)) Q:A'=+A!$D(X) D
.S B=$P($G(^AUPNVLAB(A,0)),U)
.Q:'B
.Q:'$D(^LAB(60,B,0))
.I $D(APCLLABT("LAB",B)) S X(1)=1,X=1 Q
.S J=$P($G(^AUPNVLAB(B,11)),U,13) Q:J=""
.Q:'$$LOINC(J)
.S X(1)=1,X=1
.Q
Q
LOINC(Q) ;EP - is loinc code Q in apcllabt
NEW %
S %=$P($G(^LAB(95.3,Q,9999999)),U,2)
I %]"",$D(APCLLABT("LOINC",%)) Q 1
S %=$P($G(^LAB(95.3,Q,0)),U)_"-"_$P($G(^LAB(95.3,Q,0)),U,15)
I $D(APCLLABT("LOINC",%)) Q 1
Q ""
WC(R) ;EP - return waist circumference on this visit
NEW %,M,V
S %=0,V="" F S %=$O(^AUPNVMSR("AD",R,%)) Q:%'=+% D
.Q:'$D(^AUPNVMSR(%,0))
.Q:$P($G(^AUPNVMSR(%,2)),U,1)
.S M=$P(^AUPNVMSR(%,0),U)
.I M="" Q
.S M=$P($G(^AUTTMSR(M,0)),U)
.Q:M'="WC"
.S V=$P(^AUPNVMSR(%,0),U,4)
.Q
Q V
PBMIG(P) ;EP - calculate BMI for VGEN/PGEN
NEW %,H,W,D
S %=$$PBMI^APCLV(P,DT)
I $P(%,U)="" Q ""
I $P(%,U,8)["WARNING" Q "" ;ht or wt is too old
S H=$P(%,U,3)
S W=$P(%,U,6)
S D=H
I W>H S D=W
S B=$P(%,U,1),B=$J(B,6,2),B=$$STRIP^XLFSTR(B," ")
Q B_" as of "_$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
FAMHXTL ;EP - called from pgen translation logic
K R
S Y=$O(^APCLVRPT(APCLRPT,11,APCLI,11,0)) S Z=$P($P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),"-"),R=$P($P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),"-",2)
W !,"Family History diagnoses including ",$S(Z:$P(^ICD9(Z,0),U),1:"ANY DIAGNOSIS")," for the following relationships: "
I R="" W "ANY relationship." S X="",APCLQ=1 Q
S X=0 F S X=$O(^APCLVRPT(APCLRPT,11,APCLI,11,X)) Q:X'=+X S R($P($P(^APCLVRPT(APCLRPT,11,APCLI,11,X,0),U),"-",2))=""
S X=0 F S X=$O(R(X)) Q:X'=+X W $P(^AUTTRLSH(X,0),U),"; "
K R
S X="",APCLQ=""
Q
FAMHX ;EP - called from pgen item
;find all family history items that match diagnosis and relationship
;if 1st diagnosis is blank then select ANY diagnosis that follows null
NEW D,R,I,G,S,Z,Y
K X
S X=""
S Y=0,G="" F S Y=$O(^AUPNFH("AC",DFN,Y)) Q:Y'=+Y!(G) D
.S I=$P(^AUPNFH(Y,0),U,1)
.S R=$P(^AUPNFH(Y,0),U,9)
.Q:R=""
.S R=$P(^AUPNFHR(R,0),U,1)
.;do you want this diagnosis? if so set D=1
.S D=0,S=0,Z=0 F S Z=$O(^APCLVRPT(APCLRPT,11,APCLI,11,Z)) Q:Z'=+Z!(G) D
..I $P($P(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-")="" S D=1
..I $P($P(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-")=I S D=1
..I $P($P(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-",2)=R S S=1
..I $P($P(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-",2)="" S S=1
..I D,S S G=1
I G S X=1,X(1)=""
Q
APPTS ;EP - called from pgen item
;find all appts for this patient that match, if have at least 1 then use the patient
NEW D,R,I,G,S,Z,Y,B,E,C,N,P
K C
S G=0
S Y=$O(^APCLVRPT(APCLRPT,11,APCLI,11,0))
S B=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),E=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2),C=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,3,99999)
F R=1:1 S Y=$P(C,U,R) Q:Y="" S C(Y)=""
S S=$$FMADD^XLFDT(B,-1)_".9999" F S S=$O(^DPT(DFN,"S",S)) Q:'S!(G)!($P(S,".")>E) D
.S N=^DPT(DFN,"S",S,0)
.Q:"CP"[$E($P(N,U,2)_" ")
.Q:$P(N,U,7)=4 ;skip unscheduled
.S P=+N
.I $O(C(0)),'$D(C(P)) Q ;not a clinic of interest
.S G=1
I G S X=1,X(1)=""
Q
;
APPTPRT ;EP - called from pgen item
;find all pending (non walkin, non chart request) appts for this patient
NEW D,R,I,G,S,Z,Y,B,E,C,N,P
S S=$$FMADD^XLFDT(DT,-1)_".9999" F S S=$O(^DPT(DFN,"S",S)) Q:'S D
.S N=^DPT(DFN,"S",S,0)
.Q:"CP"[$E($P(N,U,2)_" ")
.Q:$P(N,U,7)=4 ;skip unscheduled
.S A="am"
.S T=$E($P(S,".",2)_"000",1,4) S:T>1159 A="pm" S:T>1300 T=T-1200 S:$L(T)=3 T=" "_T S:$E(T)="0" T=" "_$E(T,2,4) S T=$E(T,1,2)_":"_$E(T,3,4)
.S D=$$DATE($P(S,".",1))_" "_T_A
.S C=$P(^SC($P(N,U),0),U)
.S APCLPCNT=APCLPCNT+1
.S APCLPRNM(APCLPCNT)=D_" in "_C
Q
;
DATE(D) ;EP
I $G(D)="" Q "-"
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
;
APPTTL ;EP - called from pgen translation logic for appointments
NEW R,B,E,C,Y,Z
S (R,B,E,C,Y,Z)=""
S Y=$O(^APCLVRPT(APCLRPT,11,APCLI,11,0))
S B=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),E=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2),C=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,3,99999)
W " Date range: ",$$FMTE^XLFDT(B)," - ",$$FMTE^XLFDT(E)," for:"
I C="" W !?15,"ANY (All) Appointment Clinics" S X="" Q
F R=1:1 S Y=$P(C,U,R) Q:Y="" S Z=$P(^SC(44,Y,0),U,1)_";"
W !?5,Z
S X=""
Q
PLDOOTL ;EP - called from pgen translation logic for PL DOO
NEW R,B,E,C,Y,Z
S (R,B,E,C,Y,Z)=""
S Y=$O(^APCLVRPT(APCLRPT,11,APCLI,11,0))
S B=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),E=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2)
W " Date range: ",$$FMTE^XLFDT(B)," - ",$$FMTE^XLFDT(E)
I '$D(APCLPDOO) W !?15,"for ANY (All) Diagnoses" S X="" Q
W !?15,"for a set of diagnoses including: "
S R=$O(APCLPDOO(R))
W $P(^ICD9(R,0),U)
S X=""
Q
PLDOOPRT ;EP - called from pgen item
NEW A,B,C,D,E
S (A,B,C,D,E)=""
S A=0 F S A=$O(^AUPNPROB("AC",DFN,A)) Q:A'=+A D
.Q:$P(^AUPNPROB(A,0),U,12)="D"
.S D=$$DATE($P(^AUPNPROB(A,0),U,13))
.I $D(APCLPDOO),'$D(APCLPDOO($P(^AUPNPROB(A,0),U,1))) Q
.S E=$$VAL^XBDIQ1(9000011,A,.01)
.S C="",C=D,$E(C,11)=" dx: "_E
.S APCLPCNT=APCLPCNT+1
.S APCLPRNM(APCLPCNT)=C
.Q
Q
PLDOOS ;EP - called from pgen item
;find all DOO for this patient that match, if have at least 1 then use the patient
NEW D,R,I,G,S,Z,Y,B,E,C,N,P
K C
S G=0
S Y=$O(^APCLVRPT(APCLRPT,11,APCLI,11,0))
S B=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),E=$P(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2)
S S=0 F S S=$O(^AUPNPROB("AC",DFN,S)) Q:'S!(G) D
.Q:'$D(^AUPNPROB(S,0))
.Q:$P(^AUPNPROB(S,0),U,12)="D"
.S D=$P($G(^AUPNPROB(S,0)),U,13)
.Q:D=""
.I $D(APCLPDOO),'$D(APCLPDOO($P(^AUPNPROB(S,0),U))) Q ;not a DX of interest
.Q:D<B
.Q:D>E
.S G=1
I G S X=1,X(1)=""
Q
;
ADMPROV(V,F) ;EP - called from vgen
I '$G(V) Q ""
I '$D(^AUPNVSIT(V,0)) Q ""
I $P(^AUPNVSIT(V,0),U,7)'="H" Q ""
S F=$G(F)
I F="" S F="I"
NEW A,M,X
S A=$O(^DGPM("AVISIT",V,0))
I A="" Q ""
S M=0,X="" F S M=$O(^DGPM("CA",A,M)) Q:M'=+M!(X) D
.Q:$P(^DGPM(M,0),U,2)'=6
.S X=$P($G(^DGPM(M,"IHS")),U,2)
.Q
Q $S(X="":"",F="I":X,1:$P(^VA(200,X,0),U))
IMMREGS(P,D,F) ;EP - called to get imm reg status on date D
I '$G(P) Q ""
I '$G(D) S D=DT
I '$D(^BIP(P,0)) Q "" ;not on imm reg
S F=$G(F)
I F="" S F="I"
NEW S
S S=$P(^BIP(P,0),"^",8)
I S="" Q $S(F="I":"A",1:"ACTIVE")
I S>D Q $S(F="I":"A",1:"ACTIVE")
Q $S(F="I":"I",1:"INACTIVE")
VAUDITOR(V,F) ;EP - returns the last person who marked the visit as reviewed/complete
;if visit is not reviewed/complete returns a null
I $G(V)=""
S F=$G(F)
I F="" S F="I"
I '$D(^AUPNVSIT(V,0)) Q ""
I $P(^AUPNVSIT(V,0),U,11) Q "" ;deleted
I $P($G(^AUPNVSIT(V,11)),U,11)'="R" Q "" ;visit was not reviewed/audited
NEW X,Y,A,L
K Y
S A=""
S X=0 F S X=$O(^AUPNVCA("AD",V,X)) Q:X'=+X D
.Q:'$D(^AUPNVCA(X,0))
.Q:$P(^AUPNVCA(X,0),U,4)'="R"
.S Y($P(^AUPNVCA(X,0),U,1))=X
I '$D(Y) Q ""
;get last one
S X=0 F S X=$O(Y(X)) Q:X'=+X S L=Y(X)
S Y=$P(^AUPNVCA(L,0),U,5)
I F="I" Q Y
I F="E" Q $P(^VA(200,Y,0),U)
Q ""
HOMELP(P,D) ;EP
;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
I '$O(^AUPNPAT(P,85,0)) Q "NOT RECORDED"
NEW X,Y,Z,L
S L=""
S X=0 F S X=$O(^AUPNPAT(P,85,"B",X)) Q:X'=+X D
.Q: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
..S L=Y
I L="" Q "NOT RECORDED"
I $P(^AUPNPAT(P,85,L,0),U,2)="N" Q "NOT HOMELESS"
S Z=""
S Z=$$DATE^APCLVLU($P(^AUPNPAT(P,85,L,0),U,1))_" HOMELESS "
Q Z
HOMEL(P,D) ;EP
;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
I '$O(^AUPNPAT(P,85,0)) Q "R"
S L=""
S X=0 F S X=$O(^AUPNPAT(P,85,"B",X)) Q:X'=+X D
.Q: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
..S L=Y
I L="" Q "R"
I $P(^AUPNPAT(P,85,L,0),U,2)="N" Q "N"
Q "H"
APCLVLU1 ; IHS/CMI/LAB - GEN RETR UTILITIES ; 27 Aug 2014 10:52 AM
+1 ;;2.0;IHS PCC SUITE;**2,4,5,7,11,20,21**;MAY 14, 2009;Build 34
RACESCR ;
+1 NEW Y,Z
+2 KILL Z
+3 DO LIST^DIC(2.02,","_DFN_",","@;.01E","P",,,,,,,"Z")
+4 SET Y=0
FOR
SET Y=$ORDER(Z("DILIST",Y))
IF Y=""
QUIT
SET X($PIECE(Z("DILIST",Y,0),U,1))=""
+5 QUIT
RACEPRT ;
+1 NEW Z,Y
+2 DO LIST^DIC(2.02,","_DFN_",","@;.01E","P",,,,,,,"Z")
+3 SET Y=0
FOR
SET Y=$ORDER(Z("DILIST",Y))
IF Y=""
QUIT
Begin DoDot:1
+4 ;S APCLPCNT=APCLPCNT+1
+5 SET X($PIECE(Z("DILIST",Y,0),U,1))=""
+6 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=$PIECE(Z("DILIST",Y,0),U,2)
+7 SET APCLPRNM(APCLPCNT,"I")=$PIECE(Z("DILIST",Y,0),U,1)
+8 QUIT
End DoDot:1
+9 QUIT
MCR ;MCR display all current medicare data
+1 NEW APCLMIFN
+2 IF '$DATA(^DPT(P,0))
GOTO MCRX
+3 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+4 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+5 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+6 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+7 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNMCR(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U)>D
QUIT
+9 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+10 ;IHS/CMI/LAB PATCH 21 NMCI
SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=$$GETMCR^AGUTL(P)_" ["_$SELECT($PIECE(^AUPNMCR(P,0),U,4)]"":$PIECE(^AUTTMCS($PIECE(^AUPNMCR(P,0),U,4),0),U),1:"-")_"]"
+11 SET APCLPCNT=APCLPCNT+1
SET Y=$PIECE(^AUPNMCR(DFN,11,APCLMIFN,0),U)
SET Z=$PIECE(^(0),U,2)
SET APCLPRNM(APCLPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"-"
IF Z]""
SET APCLPRNM(APCLPCNT)=APCLPRNM(APCLPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
+12 QUIT
End DoDot:1
MCRX ;
+1 KILL Y,Z
+2 QUIT
+3 ;
MCD ;EP
+1 NEW APCLMIFN,APCLNIFN
+2 IF '$DATA(^DPT(P,0))
GOTO MCDX
+3 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDX
+4 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDX
+5 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDX
+6 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNMCD("B",P,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNMCD(APCLMIFN,11))
QUIT
+8 SET APCLNIFN=0
FOR
SET APCLNIFN=$ORDER(^AUPNMCD(APCLMIFN,11,APCLNIFN))
IF APCLNIFN'=+APCLNIFN
QUIT
Begin DoDot:2
+9 IF APCLNIFN>D
QUIT
+10 IF $PIECE(^AUPNMCD(APCLMIFN,11,APCLNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=$PIECE(^AUPNMCD(APCLMIFN,0),U,3)_"/"_$SELECT($PIECE(^AUPNMCD(APCLMIFN,0),U,2)]"":$PIECE(^AUTNINS($PIECE(^AUPNMCD(APCLMIFN,0),U,2),0),U),1:"<>")
+12 SET APCLPCNT=APCLPCNT+1
SET Y=$PIECE(^AUPNMCD(APCLMIFN,11,APCLNIFN,0),U)
SET Z=$PIECE(^(0),U,2)
SET APCLPRNM(APCLPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"-"
IF Z]""
SET APCLPRNM(APCLPCNT)=APCLPRNM(APCLPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;
MCDX ;
+1 QUIT
+2 ;
PI ;EP
+1 NEW APCLMIFN,APCLFLG
+2 IF '$DATA(^DPT(P,0))
GOTO PIX
+3 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+4 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+5 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+6 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+7 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNPRVT(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
QUIT
+9 SET APCLNAME=$PIECE(^AUPNPRVT(DFN,11,APCLMIFN,0),U)
IF APCLNAME=""
QUIT
+10 IF $PIECE(^AUTNINS(APCLNAME,0),U)["AHCCCS"
QUIT
+11 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+13 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U),0),U)
+14 SET APCLPCNT=APCLPCNT+1
SET Y=$PIECE(^AUPNPRVT(DFN,11,APCLMIFN,0),U,6)
SET Z=$PIECE(^(0),U,7)
SET APCLPRNM(APCLPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"-"
IF Z]""
SET APCLPRNM(APCLPCNT)=APCLPRNM(APCLPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
+15 QUIT
End DoDot:1
PIX ;
+1 QUIT
PIV ;EP
+1 NEW APCLMIFN,APCLFLG
+2 IF '$DATA(^DPT(P,0))
GOTO PIX
+3 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+4 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+5 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+6 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+7 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNPRVT(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
QUIT
+9 SET APCLNAME=$PIECE(^AUPNPRVT(DFN,11,APCLMIFN,0),U)
IF APCLNAME=""
QUIT
+10 IF $PIECE(^AUTNINS(APCLNAME,0),U)["AHCCCS"
QUIT
+11 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+13 SET APCLPRNT=$PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,9)
IF APCLPRNT]""
SET APCLPRNT=$$FMTE^XLFDT(APCLPRNT,"2D")
+14 QUIT
End DoDot:1
PIVX ;
+1 QUIT
+2 ;
ML ;EP - set up mailing address print array
+1 SET APCLPCNT=0
KILL APCLPRNM
+2 FOR X=1:1:3
SET Y=$PIECE($GET(^DPT(DFN,.11)),U,X)
IF Y]""
SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=Y
+3 SET X=$PIECE($GET(^DPT(DFN,.11)),U,4)_", "
+4 SET Y=""
SET Y=$PIECE($GET(^DPT(DFN,.11)),U,5)
IF Y
SET Y=$PIECE(^DIC(5,Y,0),U)
+5 SET X=X_$SELECT(Y]"":Y,1:" ")
+6 SET X=X_" "_$PIECE($GET(^DPT(DFN,.11)),U,6)
+7 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=X
+8 QUIT
+9 ;
BILLNUM(V) ;EP - given visit ien (V), return bill #
+1 ;from ABMDBILL
+2 IF '$GET(V)
QUIT ""
+3 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+4 NEW D,X,B
+5 SET (D,X)=0
SET B=""
FOR
SET D=$ORDER(^ABMDBILL(D))
IF D'=+D
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^ABMDBILL(D,"AV",V,X))
IF X'=+X
QUIT
SET B=$PIECE(^ABMDBILL(D,X,0),"^")
+7 QUIT
End DoDot:1
+8 QUIT B
+9 ;
PSCLS ;EP
+1 SET A=0
FOR
SET A=$ORDER(^AUPNVPRV("AD",APCLVIEN,A))
IF A'=+A
QUIT
SET P=$PIECE(^AUPNVPRV(A,0),U)
SET Z=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(P),1:$PIECE(^DIC(7,$PIECE(^DIC(6,P,0),U,4),0),U))
Begin DoDot:1
+2 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=Z
+3 SET APCLPRNM(APCLPCNT,"I")=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE($GET(^VA(200,P,"PS")),U,5),1:$PIECE(^DIC(6,P,0),U,4))
+4 QUIT
End DoDot:1
+5 QUIT
PSAFFL ;
+1 SET A=0
FOR
SET A=$ORDER(^AUPNVPRV("AD",APCLVIEN,A))
IF A'=+A
QUIT
SET P=$PIECE(^AUPNVPRV(A,0),U)
SET Z=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$$PROVAFFL^XBFUNC1(P),1:$PIECE($GET(^DIC(6,P,9999999)),U))
Begin DoDot:1
+2 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=Z
+3 SET APCLPRNM(APCLPCNT,"I")=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE($GET(^VA(200,P,9999999)),U,1),1:$PIECE($GET(^DIC(6,P,9999999)),U))
+4 QUIT
End DoDot:1
+5 QUIT
EDPD ;EP
+1 NEW AY,P
SET AY=0
FOR
SET AY=$ORDER(^AUPNVPED("AD",APCLVIEN,AY))
IF AY'=+AY
QUIT
SET P=$PIECE(^AUPNVPED(AY,0),U,5)
IF P
Begin DoDot:1
+2 SET Z=$SELECT($PIECE(^DD(9000010.16,.05,0),U,2)[200:$$PROVCLS^XBFUNC1(P),1:$PIECE(^DIC(7,$PIECE(^DIC(6,P,0),U,4),0),U))
SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=Z
+3 SET APCLPRNM(APCLPCNT,"I")=$SELECT($PIECE(^DD(9000010.16,.05,0),U,2)[200:$PIECE($GET(^VA(200,P,"PS")),U,5),1:$PIECE($GET(^DIC(6,P,0)),U,4))
End DoDot:1
+4 QUIT
LABLOINC ;
+1 NEW A,B,C,D,J
+2 KILL X
+3 SET A=0
+4 SET APCLSPEC=""
+5 FOR
SET A=$ORDER(^AUPNVLAB("AD",APCLVIEN,A))
IF A'=+A!$DATA(X)
QUIT
Begin DoDot:1
+6 SET B=$PIECE($GET(^AUPNVLAB(A,0)),U)
+7 IF 'B
QUIT
+8 IF '$DATA(^LAB(60,B,0))
QUIT
+9 IF $DATA(APCLLABT("LAB",B))
SET X(1)=1
SET X=1
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(B,11)),U,13)
IF J=""
QUIT
+11 IF '$$LOINC(J)
QUIT
+12 SET X(1)=1
SET X=1
+13 QUIT
End DoDot:1
+14 QUIT
LOINC(Q) ;EP - is loinc code Q in apcllabt
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,Q,9999999)),U,2)
+3 IF %]""
IF $DATA(APCLLABT("LOINC",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,Q,0)),U)_"-"_$PIECE($GET(^LAB(95.3,Q,0)),U,15)
+5 IF $DATA(APCLLABT("LOINC",%))
QUIT 1
+6 QUIT ""
WC(R) ;EP - return waist circumference on this visit
+1 NEW %,M,V
+2 SET %=0
SET V=""
FOR
SET %=$ORDER(^AUPNVMSR("AD",R,%))
IF %'=+%
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVMSR(%,0))
QUIT
+4 IF $PIECE($GET(^AUPNVMSR(%,2)),U,1)
QUIT
+5 SET M=$PIECE(^AUPNVMSR(%,0),U)
+6 IF M=""
QUIT
+7 SET M=$PIECE($GET(^AUTTMSR(M,0)),U)
+8 IF M'="WC"
QUIT
+9 SET V=$PIECE(^AUPNVMSR(%,0),U,4)
+10 QUIT
End DoDot:1
+11 QUIT V
PBMIG(P) ;EP - calculate BMI for VGEN/PGEN
+1 NEW %,H,W,D
+2 SET %=$$PBMI^APCLV(P,DT)
+3 IF $PIECE(%,U)=""
QUIT ""
+4 ;ht or wt is too old
IF $PIECE(%,U,8)["WARNING"
QUIT ""
+5 SET H=$PIECE(%,U,3)
+6 SET W=$PIECE(%,U,6)
+7 SET D=H
+8 IF W>H
SET D=W
+9 SET B=$PIECE(%,U,1)
SET B=$JUSTIFY(B,6,2)
SET B=$$STRIP^XLFSTR(B," ")
+10 QUIT B_" as of "_$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+11 ;
FAMHXTL ;EP - called from pgen translation logic
+1 KILL R
+2 SET Y=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,0))
SET Z=$PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),"-")
SET R=$PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U),"-",2)
+3 WRITE !,"Family History diagnoses including ",$SELECT(Z:$PIECE(^ICD9(Z,0),U),1:"ANY DIAGNOSIS")," for the following relationships: "
+4 IF R=""
WRITE "ANY relationship."
SET X=""
SET APCLQ=1
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,X))
IF X'=+X
QUIT
SET R($PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,X,0),U),"-",2))=""
+6 SET X=0
FOR
SET X=$ORDER(R(X))
IF X'=+X
QUIT
WRITE $PIECE(^AUTTRLSH(X,0),U),"; "
+7 KILL R
+8 SET X=""
SET APCLQ=""
+9 QUIT
FAMHX ;EP - called from pgen item
+1 ;find all family history items that match diagnosis and relationship
+2 ;if 1st diagnosis is blank then select ANY diagnosis that follows null
+3 NEW D,R,I,G,S,Z,Y
+4 KILL X
+5 SET X=""
+6 SET Y=0
SET G=""
FOR
SET Y=$ORDER(^AUPNFH("AC",DFN,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:1
+7 SET I=$PIECE(^AUPNFH(Y,0),U,1)
+8 SET R=$PIECE(^AUPNFH(Y,0),U,9)
+9 IF R=""
QUIT
+10 SET R=$PIECE(^AUPNFHR(R,0),U,1)
+11 ;do you want this diagnosis? if so set D=1
+12 SET D=0
SET S=0
SET Z=0
FOR
SET Z=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+13 IF $PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-")=""
SET D=1
+14 IF $PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-")=I
SET D=1
+15 IF $PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-",2)=R
SET S=1
+16 IF $PIECE($PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Z,0),U),"-",2)=""
SET S=1
+17 IF D
IF S
SET G=1
End DoDot:2
End DoDot:1
+18 IF G
SET X=1
SET X(1)=""
+19 QUIT
APPTS ;EP - called from pgen item
+1 ;find all appts for this patient that match, if have at least 1 then use the patient
+2 NEW D,R,I,G,S,Z,Y,B,E,C,N,P
+3 KILL C
+4 SET G=0
+5 SET Y=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,0))
+6 SET B=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U)
SET E=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2)
SET C=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,3,99999)
+7 FOR R=1:1
SET Y=$PIECE(C,U,R)
IF Y=""
QUIT
SET C(Y)=""
+8 SET S=$$FMADD^XLFDT(B,-1)_".9999"
FOR
SET S=$ORDER(^DPT(DFN,"S",S))
IF 'S!(G)!($PIECE(S,".")>E)
QUIT
Begin DoDot:1
+9 SET N=^DPT(DFN,"S",S,0)
+10 IF "CP"[$EXTRACT($PIECE(N,U,2)_" ")
QUIT
+11 ;skip unscheduled
IF $PIECE(N,U,7)=4
QUIT
+12 SET P=+N
+13 ;not a clinic of interest
IF $ORDER(C(0))
IF '$DATA(C(P))
QUIT
+14 SET G=1
End DoDot:1
+15 IF G
SET X=1
SET X(1)=""
+16 QUIT
+17 ;
APPTPRT ;EP - called from pgen item
+1 ;find all pending (non walkin, non chart request) appts for this patient
+2 NEW D,R,I,G,S,Z,Y,B,E,C,N,P
+3 SET S=$$FMADD^XLFDT(DT,-1)_".9999"
FOR
SET S=$ORDER(^DPT(DFN,"S",S))
IF 'S
QUIT
Begin DoDot:1
+4 SET N=^DPT(DFN,"S",S,0)
+5 IF "CP"[$EXTRACT($PIECE(N,U,2)_" ")
QUIT
+6 ;skip unscheduled
IF $PIECE(N,U,7)=4
QUIT
+7 SET A="am"
+8 SET T=$EXTRACT($PIECE(S,".",2)_"000",1,4)
IF T>1159
SET A="pm"
IF T>1300
SET T=T-1200
IF $LENGTH(T)=3
SET T=" "_T
IF $EXTRACT(T)="0"
SET T=" "_$EXTRACT(T,2,4)
SET T=$EXTRACT(T,1,2)_":"_$EXTRACT(T,3,4)
+9 SET D=$$DATE($PIECE(S,".",1))_" "_T_A
+10 SET C=$PIECE(^SC($PIECE(N,U),0),U)
+11 SET APCLPCNT=APCLPCNT+1
+12 SET APCLPRNM(APCLPCNT)=D_" in "_C
End DoDot:1
+13 QUIT
+14 ;
DATE(D) ;EP
+1 IF $GET(D)=""
QUIT "-"
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
+3 ;
APPTTL ;EP - called from pgen translation logic for appointments
+1 NEW R,B,E,C,Y,Z
+2 SET (R,B,E,C,Y,Z)=""
+3 SET Y=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,0))
+4 SET B=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U)
SET E=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2)
SET C=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,3,99999)
+5 WRITE " Date range: ",$$FMTE^XLFDT(B)," - ",$$FMTE^XLFDT(E)," for:"
+6 IF C=""
WRITE !?15,"ANY (All) Appointment Clinics"
SET X=""
QUIT
+7 FOR R=1:1
SET Y=$PIECE(C,U,R)
IF Y=""
QUIT
SET Z=$PIECE(^SC(44,Y,0),U,1)_";"
+8 WRITE !?5,Z
+9 SET X=""
+10 QUIT
PLDOOTL ;EP - called from pgen translation logic for PL DOO
+1 NEW R,B,E,C,Y,Z
+2 SET (R,B,E,C,Y,Z)=""
+3 SET Y=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,0))
+4 SET B=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U)
SET E=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2)
+5 WRITE " Date range: ",$$FMTE^XLFDT(B)," - ",$$FMTE^XLFDT(E)
+6 IF '$DATA(APCLPDOO)
WRITE !?15,"for ANY (All) Diagnoses"
SET X=""
QUIT
+7 WRITE !?15,"for a set of diagnoses including: "
+8 SET R=$ORDER(APCLPDOO(R))
+9 WRITE $PIECE(^ICD9(R,0),U)
+10 SET X=""
+11 QUIT
PLDOOPRT ;EP - called from pgen item
+1 NEW A,B,C,D,E
+2 SET (A,B,C,D,E)=""
+3 SET A=0
FOR
SET A=$ORDER(^AUPNPROB("AC",DFN,A))
IF A'=+A
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(A,0),U,12)="D"
QUIT
+5 SET D=$$DATE($PIECE(^AUPNPROB(A,0),U,13))
+6 IF $DATA(APCLPDOO)
IF '$DATA(APCLPDOO($PIECE(^AUPNPROB(A,0),U,1)))
QUIT
+7 SET E=$$VAL^XBDIQ1(9000011,A,.01)
+8 SET C=""
SET C=D
SET $EXTRACT(C,11)=" dx: "_E
+9 SET APCLPCNT=APCLPCNT+1
+10 SET APCLPRNM(APCLPCNT)=C
+11 QUIT
End DoDot:1
+12 QUIT
PLDOOS ;EP - called from pgen item
+1 ;find all DOO for this patient that match, if have at least 1 then use the patient
+2 NEW D,R,I,G,S,Z,Y,B,E,C,N,P
+3 KILL C
+4 SET G=0
+5 SET Y=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,0))
+6 SET B=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U)
SET E=$PIECE(^APCLVRPT(APCLRPT,11,APCLI,11,Y,0),U,2)
+7 SET S=0
FOR
SET S=$ORDER(^AUPNPROB("AC",DFN,S))
IF 'S!(G)
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNPROB(S,0))
QUIT
+9 IF $PIECE(^AUPNPROB(S,0),U,12)="D"
QUIT
+10 SET D=$PIECE($GET(^AUPNPROB(S,0)),U,13)
+11 IF D=""
QUIT
+12 ;not a DX of interest
IF $DATA(APCLPDOO)
IF '$DATA(APCLPDOO($PIECE(^AUPNPROB(S,0),U)))
QUIT
+13 IF D<B
QUIT
+14 IF D>E
QUIT
+15 SET G=1
End DoDot:1
+16 IF G
SET X=1
SET X(1)=""
+17 QUIT
+18 ;
ADMPROV(V,F) ;EP - called from vgen
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V,0))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT ""
+4 SET F=$GET(F)
+5 IF F=""
SET F="I"
+6 NEW A,M,X
+7 SET A=$ORDER(^DGPM("AVISIT",V,0))
+8 IF A=""
QUIT ""
+9 SET M=0
SET X=""
FOR
SET M=$ORDER(^DGPM("CA",A,M))
IF M'=+M!(X)
QUIT
Begin DoDot:1
+10 IF $PIECE(^DGPM(M,0),U,2)'=6
QUIT
+11 SET X=$PIECE($GET(^DGPM(M,"IHS")),U,2)
+12 QUIT
End DoDot:1
+13 QUIT $SELECT(X="":"",F="I":X,1:$PIECE(^VA(200,X,0),U))
IMMREGS(P,D,F) ;EP - called to get imm reg status on date D
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(D)
SET D=DT
+3 ;not on imm reg
IF '$DATA(^BIP(P,0))
QUIT ""
+4 SET F=$GET(F)
+5 IF F=""
SET F="I"
+6 NEW S
+7 SET S=$PIECE(^BIP(P,0),"^",8)
+8 IF S=""
QUIT $SELECT(F="I":"A",1:"ACTIVE")
+9 IF S>D
QUIT $SELECT(F="I":"A",1:"ACTIVE")
+10 QUIT $SELECT(F="I":"I",1:"INACTIVE")
VAUDITOR(V,F) ;EP - returns the last person who marked the visit as reviewed/complete
+1 ;if visit is not reviewed/complete returns a null
+2 IF $GET(V)=""
+3 SET F=$GET(F)
+4 IF F=""
SET F="I"
+5 IF '$DATA(^AUPNVSIT(V,0))
QUIT ""
+6 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT ""
+7 ;visit was not reviewed/audited
IF $PIECE($GET(^AUPNVSIT(V,11)),U,11)'="R"
QUIT ""
+8 NEW X,Y,A,L
+9 KILL Y
+10 SET A=""
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVCA("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVCA(X,0))
QUIT
+13 IF $PIECE(^AUPNVCA(X,0),U,4)'="R"
QUIT
+14 SET Y($PIECE(^AUPNVCA(X,0),U,1))=X
End DoDot:1
+15 IF '$DATA(Y)
QUIT ""
+16 ;get last one
+17 SET X=0
FOR
SET X=$ORDER(Y(X))
IF X'=+X
QUIT
SET L=Y(X)
+18 SET Y=$PIECE(^AUPNVCA(L,0),U,5)
+19 IF F="I"
QUIT Y
+20 IF F="E"
QUIT $PIECE(^VA(200,Y,0),U)
+21 QUIT ""
HOMELP(P,D) ;EP
+1 ;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
+2 IF '$ORDER(^AUPNPAT(P,85,0))
QUIT "NOT RECORDED"
+3 NEW X,Y,Z,L
+4 SET L=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(P,85,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF X>D
QUIT
+7 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,85,"B",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)=""
QUIT
+9 SET L=Y
End DoDot:2
End DoDot:1
+10 IF L=""
QUIT "NOT RECORDED"
+11 IF $PIECE(^AUPNPAT(P,85,L,0),U,2)="N"
QUIT "NOT HOMELESS"
+12 SET Z=""
+13 SET Z=$$DATE^APCLVLU($PIECE(^AUPNPAT(P,85,L,0),U,1))_" HOMELESS "
+14 QUIT Z
HOMEL(P,D) ;EP
+1 ;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
+2 IF '$ORDER(^AUPNPAT(P,85,0))
QUIT "R"
+3 SET L=""
+4 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(P,85,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+5 IF X>D
QUIT
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,85,"B",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)=""
QUIT
+8 SET L=Y
End DoDot:2
End DoDot:1
+9 IF L=""
QUIT "R"
+10 IF $PIECE(^AUPNPAT(P,85,L,0),U,2)="N"
QUIT "N"
+11 QUIT "H"
