APCLVLU ; IHS/CMI/LAB - GEN RETR UTILITIES ;
;;2.0;IHS PCC SUITE;**2,4,5,10,11,20**;MAY 14, 2009;Build 25
;IHS/CMI/LAB - patch 4 added anyins
;
RZERO(V,L) ;EP right zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
Q V
LZERO(V,L) ;EP left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
ANYINS(P,D) ;EP return 1 or 0 if patient has any insurance
NEW APCLA
S APCLA=0
S APCLA=$$MCR^AUPNPAT(P,D) I APCLA Q APCLA
S APCLA=$$MCD^AUPNPAT(P,D) I APCLA Q APCLA
S APCLA=$$PI^AUPNPAT(P,D)
Q APCLA
;
MCR(P,D,F) ;is patient medicare eligible on this date
NEW APCLMIFN,APCLFLG
S APCLFLG=0
S F=$G(F)
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
.I F]"",$P(^AUPNMCR(P,11,APCLMIFN,0),U,3)'=F Q
.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 APCLFLG=1
.Q
MCRX ;
Q APCLFLG
;
MCD(P,D) ;
NEW APCLMIFN,APCLNIFN,APCLFLG
S APCLFLG=0
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 APCLFLG=1
..Q
.Q
;
MCDX ;
Q APCLFLG
;
MCDPN(P,D,F) ;EP - return medicaid plan name
NEW APCLMIFN,APCLNIFN,APCLPN
S APCLPN=""
I '$D(^DPT(P,0)) G MCDPNX
I $P(^DPT(P,0),U,19) G MCDPNX
I '$D(^AUPNPAT(P,0)) G MCDPNX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDPNX
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 APCLPN=$P(^AUPNMCD(APCLMIFN,0),U,10) I APCLPN]"" S APCLPN=$S(F="E":$P(^AUTNINS(APCLPN,0),U),1:APCLPN)
..Q
.Q
;
MCDPNX ;
Q APCLPN
PI(P,D) ;
NEW APCLMIFN,APCLFLG
S APCLFLG=0
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(P,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 APCLFLG=1
.Q
PIX ;
Q APCLFLG
PIV(P,D) ;EP - return 1 or 0 if current pi policy has been verified, return 1
NEW APCLMIFN,APCLFLG
S APCLFLG=0
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(P,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
.Q:$P(^AUPNPRVT(P,11,APCLMIFN,0),U,9)=""
.S APCLFLG=1
.Q
PIVX ;
Q APCLFLG
;
PIN(P,D,F) ;EP private insurer name (external or internal)
NEW APCLMIFN,APCLPIN,Y
S:$G(F)="" F="E"
S APCLPIN="",Y=""
I '$D(^DPT(P,0)) G PINX
I $P(^DPT(P,0),U,19) G PINX
I '$D(^AUPNPAT(P,0)) G PINX
I '$D(^AUPNPRVT(P,11)) G PINX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PINX
S APCLMIFN=0 F S APCLMIFN=$O(^AUPNPRVT(P,11,APCLMIFN)) Q:APCLMIFN'=+APCLMIFN D
.Q:$P(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
.S Y=$P(^AUPNPRVT(P,11,APCLMIFN,0),U)
.I $P(^AUTNINS(Y,0),U)["AHCCCS" Q
.I $P(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D Q
.I $P(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
.S APCLPIN=$S(F="E":$P(^AUTNINS(Y,0),U),1:Y)
.Q
PINX ;
Q APCLPIN
LOS(V) ;EP called from pcc man rpts visit sort
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $P(^AUPNVSIT(V,0),U,7)'="H" Q ""
I $P(^AUPNVSIT(V,0),U,3)="C",'$D(^AUPNVCHS("AD",V)) Q ""
I $P(^AUPNVSIT(V,0),U,3)'="C",'$D(^AUPNVINP("AD",V)) Q ""
NEW D,E,F,A
S A=$P($P(^AUPNVSIT(V,0),U),".")
S F=$S($D(^AUPNVINP("AD",V)):$O(^AUPNVINP("AD",V,0)),$D(^AUPNVCHS("AD",V)):$O(^AUPNVCHS("AD",V,0)),1:"")
I F="" Q F
S D=$S($D(^AUPNVINP("AD",V)):$P(^AUPNVINP(F,0),U),$D(^AUPNVCHS("AD",V)):$P(^AUPNVCHS(F,0),U,12),1:"")
I D="" Q D
S E=$$FMDIFF^XLFDT(D,A,1)
Q $S('E:1,1:E)
THIRD ;EP
S APCLPRNT=""
S X=$$MCR^AUPNPAT(DFN,$S(APCLPTVS="V":$P(APCLVREC,U),1:DT)) S:X APCLPRNT=APCLPRNT_"MEDICARE "
S X=$$MCD^AUPNPAT(DFN,$S(APCLPTVS="V":$P(APCLVREC,U),1:DT)) S:X APCLPRNT=APCLPRNT_"MEDICAID "
S X=$$PI^AUPNPAT(DFN,$S(APCLPTVS="V":$P(APCLVREC,U),1:DT)) S:X APCLPRNT=APCLPRNT_"PRVT INS "
S:APCLPRNT="" APCLPRNT="<none>"
Q
LASTHF(P,C,F) ;EP - get last factor in category C for patient P
I '$G(P) Q ""
I $G(C)="" Q ""
I $G(F)="" S F="N"
S C=$O(^AUTTHF("B",C,0)) ;ien of category passed
I '$G(C) Q ""
NEW H,D,O S H=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
. Q:'$D(^AUPNVHF("AA",P,H))
. S D=$O(^AUPNVHF("AA",P,H,""))
. Q:'D
. S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
. Q
S D=$O(O(0))
I D="" Q D
I F="I" Q $P(^AUPNVHF(O(D),0),U)
I F="N" Q $P(^AUTTHF($P(^AUPNVHF(O(D),0),U),0),U)_" "_$$FMTE^XLFDT((9999999-D),2)
Q ""
;
LASTTOHF(P,C,F) ;EP - get last factor in tobacco categories for patient P
I '$G(P) Q ""
I $G(C)="" S C=""
I $G(F)="" S F="N"
NEW L,M,N
S L=$O(^AUTTHF("B","TOBACCO (SMOKING)",0))
S M=$O(^AUTTHF("B","TOBACCO (SMOKELESS - CHEWING/DIP)",0))
S N=$O(^AUTTHF("B","TOBACCO (EXPOSURE)",0))
NEW H,D,O S H=0 K O
F C=L,M,N F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
. Q:'$D(^AUPNVHF("AA",P,H))
. S D=$O(^AUPNVHF("AA",P,H,""))
. Q:'D
. S O(D)=$O(^AUPNVHF("AA",P,H,D,9999999999),-1)
. Q
S D=$O(O(0))
I D="" Q D
I F="I" Q $P(^AUPNVHF(O(D),0),U)
I F="N" Q $P(^AUTTHF($P(^AUPNVHF(O(D),0),U),0),U)_" "_$$FMTE^XLFDT((9999999-D),2)
Q ""
;
HFC(V) ;EP - get last factor in category C for patient P
NEW A,B,C,D
S A=0 F S A=$O(^AUPNVHF("AD",V,A)) Q:A'=+A D
.S B=$P($G(^AUPNVHF(A,0)),U)
.Q:B=""
.S C=$P($G(^AUTTHF(B,0)),U,3)
.Q:C=""
.S X(C)=""
.Q
Q
HFCP ;EP get all hfs in category stored
NEW A,B,C,D
S A=0 F S A=$O(^AUPNVHF("AD",APCLVIEN,A)) Q:A'=+A D
.S B=$P($G(^AUPNVHF(A,0)),U)
.Q:B=""
.S C=$P($G(^AUTTHF(B,0)),U,3)
.Q:C=""
.S D=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U)
.Q:'$D(^APCLVRPT(APCLRPT,11,D,11,"B",C))
.S APCLPRNT=$P(^AUTTHF(B,0),U)
.S APCLPCNT=APCLPCNT+1,APCLPRNM(APCLPCNT)=APCLPRNT_" "_$$VD^APCLV(APCLVIEN,"S"),APCLPRNM(APCLPCNT,"I")=C
.Q
Q
;
ADMWARD(V) ;EP return admission ward for this visit
;must be running PIMS
;
PN(V,R,I) ;EP
NEW Y,N,Z,G,A S A=""
S Y=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y D
.S N=$P($G(^AUPNVPOV(Y,0)),U,4)
.Q:N=""
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) ;$P($G(^AUTNPOV(N,0)),U)
.Q:N=""
.S Z=0 F S Z=$O(^APCLVRPT(R,11,I,11,Z)) Q:Z'=+Z D
..S G=$P($G(^APCLVRPT(R,11,I,11,Z,0)),U)
..I N[G S A=1
..Q
.Q
Q A
EDOB(V,R,I) ;EP
NEW Y,N,Z,G,A S A=""
S Y=0 F S Y=$O(^AUPNVPED("AD",V,Y)) Q:Y'=+Y D
.S N=$P($G(^AUPNVPED(Y,0)),U,14)
.S N=$$UP^XLFSTR(N)
.S Z=0 F S Z=$O(^APCLVRPT(R,11,I,11,Z)) Q:Z'=+Z D
..S G=$$UP^XLFSTR($P($G(^APCLVRPT(R,11,I,11,Z,0)),U))
..I N[G S A=1
..Q
.Q
Q A
MCRD(P,D) ;is patient medicare eligible on this date
NEW APCLMIFN,APCLFLG
S APCLFLG=0
S F=$G(F)
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
.I $P(^AUPNMCR(P,11,APCLMIFN,0),U,3)'="D" Q
.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 APCLFLG=1
.Q
I APCLFLG Q APCLFLG
;now check PI for D- or MD in 2nd piece of 2 node (per Shonda)
S APCLFLG=$$PIDD^APCLOS21(DFN,D) ;check for D- in private insurer name
Q APCLFLG
;
LASTINUD(P,D) ;EP - last date internet access was updated as of date D
I $G(D)="" S D=DT
I '$G(P)="" Q ""
I '$D(^AUPNPAT(P,81)) Q ""
NEW X,Y
S X=0,Y="" F S X=$O(^AUPNPAT(P,81,"B",X)) Q:X'=+X!(X>D) S Y=X
Q Y
;
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
LASTINYN(P,F,D) ;EP - last response to does patient have internet access? as of date D
I '$G(P)="" Q ""
I $G(D)="" S D=DT
S F=$G(F)
I '$D(^AUPNPAT(P,81)) Q ""
NEW X,Y,Z
S Z=""
S X=0,Y="" F S X=$O(^AUPNPAT(P,81,"B",X)) Q:X'=+X!(X>D) S Y=0 F S Y=$O(^AUPNPAT(P,81,"B",X,Y)) Q:Y'=+Y S Z=Y
I Z="" Q Z
I F="I" Q $P(^AUPNPAT(P,81,Z,0),U,2)
Q $$GET1^DIQ(9000001.81,Z_","_P_",",.02)
;
LASTINAC(P,F,D) ;EP - last response to does patient have internet access?
;as of date D
I '$G(P)="" Q ""
S F=$G(F)
S D=$G(D)
I D="" S D=DT
I '$D(^AUPNPAT(P,81)) Q ""
NEW X,Y,Z
S Z=""
S X=0,Y="" F S X=$O(^AUPNPAT(P,81,"B",X)) Q:X'=+X!(X>D) S Y=0 F S Y=$O(^AUPNPAT(P,81,"B",X,Y)) Q:Y'=+Y S Z=Y
I Z="" Q Z
I F="I" Q $P(^AUPNPAT(P,81,Z,0),U,3)
Q $$GET1^DIQ(9000001.81,Z_","_P_",",.03)
;
MEDQD ;EP - return med/qty/days formatted
NEW P,X,Q,D
S APCLPCNT=0
S P=0 F S P=$O(^AUPNVMED("AD",APCLVIEN,P)) Q:P'=+P D
.S APCLPRNT="",X=""
.S X=$$RBLK^APCLUTL($E($$VAL^XBDIQ1(9000010.14,P,.01),1,30),30)
.S Q=$$RBLK^APCLUTL(" Qty: "_$P(^AUPNVMED(P,0),U,6),13)
.S D=" Days: "_$P(^AUPNVMED(P,0),U,7)
.S APCLPCNT=APCLPCNT+1
.S APCLPRNM(APCLPCNT)=X_Q_D
.S APCLPRNM(APCLPCNT,"I")=$P(^AUPNVMED(P,0),U)
.Q
Q
FAMHX ;EP - return FAMILY HISTORY AND RELATIONSHIP
NEW P,X,Q,D
S APCLPCNT=0
S P=0 F S P=$O(^AUPNFH("AC",DFN,P)) Q:P'=+P D
.S APCLPRNT="",X=""
.S X=$$VAL^XBDIQ1(9000014,P,.01)
.S Q=$$VAL^XBDIQ1(9000014,P,.09)
.S APCLPCNT=APCLPCNT+1
.S APCLPRNM(APCLPCNT)=Q_" "_$$VAL^XBDIQ1(9000014.1,$P(^AUPNFH(P,0),U,9),.03)_"; "_X
.;S APCLPRNM(APCLPCNT,"I")=$P(^AUPNVMED(P,0),U)
.Q
Q
FAMHXP ;EP - return FAMILY HISTORY DESCRIPTION
NEW P,X,Q,D
S APCLPCNT=0
S P=0 F S P=$O(^AUPNFH("AC",DFN,P)) Q:P'=+P D
.S APCLPRNT="",X=""
.S X=$$VAL^XBDIQ1(9000014,P,.01)
.S Q=$$VAL^XBDIQ1(9000014,P,.09)
.S APCLPCNT=APCLPCNT+1
.S APCLPRNM(APCLPCNT)=Q_" "_$$VAL^XBDIQ1(9000014.1,$P(^AUPNFH(P,0),U,9),.03)_"; "_X_"; "_$$VAL^XBDIQ1(9000014,P,.04)_"; Age at Onset: "_$$VAL^XBDIQ1(9000014,P,.05) ;LORI MU
.;S APCLPRNM(APCLPCNT,"I")=$P(^AUPNVMED(P,0),U)
.Q
Q
ALLCPTS(V,RETVAL) ;EP - return in array RETVAL all cpts ien of visit V - used in VGEN
NEW A,B,C,D
S C=0
;V CPT
S A=0 F S A=$O(^AUPNVCPT("AD",V,A)) Q:A'=+A I $P($G(^AUPNVCPT(A,0)),U) S RETVAL($P(^AUPNVCPT(A,0),U))=""
;V PROCEDURE
S A=0 F S A=$O(^AUPNVPRC("AD",V,A)) Q:A'=+A I $P($G(^AUPNVPRC(A,0)),U,16) S RETVAL($P(^AUPNVPRC(A,0),U,16))=""
;VISIT E&M
S A=$P(^AUPNVSIT(V,0),U,17) I A S RETVAL(A)=""
;V TRAN CODES
S A=0 F S A=$O(^AUPNVTC("AD",V,A)) Q:A'=+A I $P($G(^AUPNVTC(A,0)),U,7) S RETVAL($P(^AUPNVTC(A,0),U,7))=""
;V PAT ED
S A=0 F S A=$O(^AUPNVPED("AD",APCLVIEN,A)) Q:A'=+A I $P($G(^AUPNVPED(A,0)),U,9) S X($P(^AUPNVPED(A,0),U,9))=""
Q
ALLCPTSP(V,RETVAL) ;EP - return in array RETVAL all cpts ien of visit V - used in VGEN
NEW A,B,C,D
S C=0
;V CPT
S A=0 F S A=$O(^AUPNVCPT("AD",V,A)) Q:A'=+A S Z=$P($G(^AUPNVCPT(A,0)),U) I Z S C=C+1,RETVAL(C)=$$VAL^XBDIQ1(9000010.18,A,.01),RETVAL(C,"I")=Z
;V PROCEDURE
S A=0 F S A=$O(^AUPNVPRC("AD",V,A)) Q:A'=+A S Z=$P($G(^AUPNVPRC(A,0)),U,16) I Z S C=C+1,RETVAL(C)=$$VAL^XBDIQ1(9000010.08,A,.16),RETVAL(C,"I")=Z
;VISIT E&M
S A=$P(^AUPNVSIT(V,0),U,17) I A S C=C+1,RETVAL(C)=$$VAL^XBDIQ1(9000010,A,.17),RETVAL(C,"I")=A
;V TRAN CODES
S A=0 F S A=$O(^AUPNVTC("AD",V,A)) Q:A'=+A S Z=$$VALI^XBDIQ1(9000010.33,A,.07) I Z S C=C+1,RETVAL(C)=$$VAL^XBDIQ1(9000010.33,A,.07),RETVAL(C,"I")=Z
;V PAT ED
S A=0 F S A=$O(^AUPNVPED("AD",APCLVIEN,A)) Q:A'=+A S Z=$$VALI^XBDIQ1(9000010.16,A,.09) I Z S C=C+1,RETVAL(C)=$$VAL^XBDIQ1(9000010.16,A,.09),RETVAL(C,"I")=Z
Q
PMEAS ;
NEW APCLX
S APCLX=0 F S APCLX=$O(^AUPNVMSR("AD",APCLVIEN,APCLX)) Q:APCLX'=+APCLX D
.Q:$P($G(^AUPNVMSR(APCLX,2)),U)
.S APCLPRNT=$$VAL^XBDIQ1(9000010.01,APCLX,.01)
.S APCLPCNT=APCLPCNT+1
.S APCLPRNM(APCLPCNT)=APCLPRNT_" "_$$R($$VAL^XBDIQ1(9000010.01,APCLX,.01),$$VAL^XBDIQ1(9000010.01,APCLX,.04)) ;$P(^AUPNVMSR(APCLX,0),U,4)
.S APCLPRNM(APCLPCNT,"I")=$P(^AUPNVMSR(APCLX,0),U)
.Q
Q
R(T,V) ;
I T'="HT",T'="WT",T'="BMI" Q V
I V'["." Q V
Q $TR($J(V,7,2)," ")
APCLVLU ; IHS/CMI/LAB - GEN RETR UTILITIES ;
+1 ;;2.0;IHS PCC SUITE;**2,4,5,10,11,20**;MAY 14, 2009;Build 25
+2 ;IHS/CMI/LAB - patch 4 added anyins
+3 ;
RZERO(V,L) ;EP right zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_"0"
+3 QUIT V
LZERO(V,L) ;EP left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
ANYINS(P,D) ;EP return 1 or 0 if patient has any insurance
+1 NEW APCLA
+2 SET APCLA=0
+3 SET APCLA=$$MCR^AUPNPAT(P,D)
IF APCLA
QUIT APCLA
+4 SET APCLA=$$MCD^AUPNPAT(P,D)
IF APCLA
QUIT APCLA
+5 SET APCLA=$$PI^AUPNPAT(P,D)
+6 QUIT APCLA
+7 ;
MCR(P,D,F) ;is patient medicare eligible on this date
+1 NEW APCLMIFN,APCLFLG
+2 SET APCLFLG=0
+3 SET F=$GET(F)
+4 IF '$DATA(^DPT(P,0))
GOTO MCRX
+5 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+6 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+7 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+8 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+9 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNMCR(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+10 IF F]""
IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U,3)'=F
QUIT
+11 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U)>D
QUIT
+12 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+13 SET APCLFLG=1
+14 QUIT
End DoDot:1
MCRX ;
+1 QUIT APCLFLG
+2 ;
MCD(P,D) ;
+1 NEW APCLMIFN,APCLNIFN,APCLFLG
+2 SET APCLFLG=0
+3 IF '$DATA(^DPT(P,0))
GOTO MCDX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDX
+6 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDX
+7 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNMCD("B",P,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNMCD(APCLMIFN,11))
QUIT
+9 SET APCLNIFN=0
FOR
SET APCLNIFN=$ORDER(^AUPNMCD(APCLMIFN,11,APCLNIFN))
IF APCLNIFN'=+APCLNIFN
QUIT
Begin DoDot:2
+10 IF APCLNIFN>D
QUIT
+11 IF $PIECE(^AUPNMCD(APCLMIFN,11,APCLNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+12 SET APCLFLG=1
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;
MCDX ;
+1 QUIT APCLFLG
+2 ;
MCDPN(P,D,F) ;EP - return medicaid plan name
+1 NEW APCLMIFN,APCLNIFN,APCLPN
+2 SET APCLPN=""
+3 IF '$DATA(^DPT(P,0))
GOTO MCDPNX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDPNX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDPNX
+6 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDPNX
+7 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNMCD("B",P,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNMCD(APCLMIFN,11))
QUIT
+9 SET APCLNIFN=0
FOR
SET APCLNIFN=$ORDER(^AUPNMCD(APCLMIFN,11,APCLNIFN))
IF APCLNIFN'=+APCLNIFN
QUIT
Begin DoDot:2
+10 IF APCLNIFN>D
QUIT
+11 IF $PIECE(^AUPNMCD(APCLMIFN,11,APCLNIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+12 SET APCLPN=$PIECE(^AUPNMCD(APCLMIFN,0),U,10)
IF APCLPN]""
SET APCLPN=$SELECT(F="E":$PIECE(^AUTNINS(APCLPN,0),U),1:APCLPN)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;
MCDPNX ;
+1 QUIT APCLPN
PI(P,D) ;
+1 NEW APCLMIFN,APCLFLG
+2 SET APCLFLG=0
+3 IF '$DATA(^DPT(P,0))
GOTO PIX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+6 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+7 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+8 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNPRVT(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
QUIT
+10 SET APCLNAME=$PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)
IF APCLNAME=""
QUIT
+11 IF $PIECE(^AUTNINS(APCLNAME,0),U)["AHCCCS"
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
QUIT
+13 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+14 SET APCLFLG=1
+15 QUIT
End DoDot:1
PIX ;
+1 QUIT APCLFLG
PIV(P,D) ;EP - return 1 or 0 if current pi policy has been verified, return 1
+1 NEW APCLMIFN,APCLFLG
+2 SET APCLFLG=0
+3 IF '$DATA(^DPT(P,0))
GOTO PIX
+4 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+5 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+6 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+7 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+8 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNPRVT(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
QUIT
+10 SET APCLNAME=$PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)
IF APCLNAME=""
QUIT
+11 IF $PIECE(^AUTNINS(APCLNAME,0),U)["AHCCCS"
QUIT
+12 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
QUIT
+13 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+14 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,9)=""
QUIT
+15 SET APCLFLG=1
+16 QUIT
End DoDot:1
PIVX ;
+1 QUIT APCLFLG
+2 ;
PIN(P,D,F) ;EP private insurer name (external or internal)
+1 NEW APCLMIFN,APCLPIN,Y
+2 IF $GET(F)=""
SET F="E"
+3 SET APCLPIN=""
SET Y=""
+4 IF '$DATA(^DPT(P,0))
GOTO PINX
+5 IF $PIECE(^DPT(P,0),U,19)
GOTO PINX
+6 IF '$DATA(^AUPNPAT(P,0))
GOTO PINX
+7 IF '$DATA(^AUPNPRVT(P,11))
GOTO PINX
+8 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PINX
+9 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNPRVT(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+10 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)=""
QUIT
+11 SET Y=$PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U)
+12 IF $PIECE(^AUTNINS(Y,0),U)["AHCCCS"
QUIT
+13 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,6)>D
QUIT
+14 IF $PIECE(^AUPNPRVT(P,11,APCLMIFN,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+15 SET APCLPIN=$SELECT(F="E":$PIECE(^AUTNINS(Y,0),U),1:Y)
+16 QUIT
End DoDot:1
PINX ;
+1 QUIT APCLPIN
LOS(V) ;EP called from pcc man rpts visit sort
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT ""
+4 IF $PIECE(^AUPNVSIT(V,0),U,3)="C"
IF '$DATA(^AUPNVCHS("AD",V))
QUIT ""
+5 IF $PIECE(^AUPNVSIT(V,0),U,3)'="C"
IF '$DATA(^AUPNVINP("AD",V))
QUIT ""
+6 NEW D,E,F,A
+7 SET A=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+8 SET F=$SELECT($DATA(^AUPNVINP("AD",V)):$ORDER(^AUPNVINP("AD",V,0)),$DATA(^AUPNVCHS("AD",V)):$ORDER(^AUPNVCHS("AD",V,0)),1:"")
+9 IF F=""
QUIT F
+10 SET D=$SELECT($DATA(^AUPNVINP("AD",V)):$PIECE(^AUPNVINP(F,0),U),$DATA(^AUPNVCHS("AD",V)):$PIECE(^AUPNVCHS(F,0),U,12),1:"")
+11 IF D=""
QUIT D
+12 SET E=$$FMDIFF^XLFDT(D,A,1)
+13 QUIT $SELECT('E:1,1:E)
THIRD ;EP
+1 SET APCLPRNT=""
+2 SET X=$$MCR^AUPNPAT(DFN,$SELECT(APCLPTVS="V":$PIECE(APCLVREC,U),1:DT))
IF X
SET APCLPRNT=APCLPRNT_"MEDICARE "
+3 SET X=$$MCD^AUPNPAT(DFN,$SELECT(APCLPTVS="V":$PIECE(APCLVREC,U),1:DT))
IF X
SET APCLPRNT=APCLPRNT_"MEDICAID "
+4 SET X=$$PI^AUPNPAT(DFN,$SELECT(APCLPTVS="V":$PIECE(APCLVREC,U),1:DT))
IF X
SET APCLPRNT=APCLPRNT_"PRVT INS "
+5 IF APCLPRNT=""
SET APCLPRNT="<none>"
+6 QUIT
LASTHF(P,C,F) ;EP - get last factor in category C for patient P
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(C)=""
QUIT ""
+3 IF $GET(F)=""
SET F="N"
+4 ;ien of category passed
SET C=$ORDER(^AUTTHF("B",C,0))
+5 IF '$GET(C)
QUIT ""
+6 NEW H,D,O
SET H=0
KILL O
+7 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+9 SET D=$ORDER(^AUPNVHF("AA",P,H,""))
+10 IF 'D
QUIT
+11 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
+12 QUIT
End DoDot:1
+13 SET D=$ORDER(O(0))
+14 IF D=""
QUIT D
+15 IF F="I"
QUIT $PIECE(^AUPNVHF(O(D),0),U)
+16 IF F="N"
QUIT $PIECE(^AUTTHF($PIECE(^AUPNVHF(O(D),0),U),0),U)_" "_$$FMTE^XLFDT((9999999-D),2)
+17 QUIT ""
+18 ;
LASTTOHF(P,C,F) ;EP - get last factor in tobacco categories for patient P
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(C)=""
SET C=""
+3 IF $GET(F)=""
SET F="N"
+4 NEW L,M,N
+5 SET L=$ORDER(^AUTTHF("B","TOBACCO (SMOKING)",0))
+6 SET M=$ORDER(^AUTTHF("B","TOBACCO (SMOKELESS - CHEWING/DIP)",0))
+7 SET N=$ORDER(^AUTTHF("B","TOBACCO (EXPOSURE)",0))
+8 NEW H,D,O
SET H=0
KILL O
+9 FOR C=L,M,N
FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+11 SET D=$ORDER(^AUPNVHF("AA",P,H,""))
+12 IF 'D
QUIT
+13 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,9999999999),-1)
+14 QUIT
End DoDot:1
+15 SET D=$ORDER(O(0))
+16 IF D=""
QUIT D
+17 IF F="I"
QUIT $PIECE(^AUPNVHF(O(D),0),U)
+18 IF F="N"
QUIT $PIECE(^AUTTHF($PIECE(^AUPNVHF(O(D),0),U),0),U)_" "_$$FMTE^XLFDT((9999999-D),2)
+19 QUIT ""
+20 ;
HFC(V) ;EP - get last factor in category C for patient P
+1 NEW A,B,C,D
+2 SET A=0
FOR
SET A=$ORDER(^AUPNVHF("AD",V,A))
IF A'=+A
QUIT
Begin DoDot:1
+3 SET B=$PIECE($GET(^AUPNVHF(A,0)),U)
+4 IF B=""
QUIT
+5 SET C=$PIECE($GET(^AUTTHF(B,0)),U,3)
+6 IF C=""
QUIT
+7 SET X(C)=""
+8 QUIT
End DoDot:1
+9 QUIT
HFCP ;EP get all hfs in category stored
+1 NEW A,B,C,D
+2 SET A=0
FOR
SET A=$ORDER(^AUPNVHF("AD",APCLVIEN,A))
IF A'=+A
QUIT
Begin DoDot:1
+3 SET B=$PIECE($GET(^AUPNVHF(A,0)),U)
+4 IF B=""
QUIT
+5 SET C=$PIECE($GET(^AUTTHF(B,0)),U,3)
+6 IF C=""
QUIT
+7 SET D=$PIECE(^APCLVRPT(APCLRPT,12,APCLI,0),U)
+8 IF '$DATA(^APCLVRPT(APCLRPT,11,D,11,"B",C))
QUIT
+9 SET APCLPRNT=$PIECE(^AUTTHF(B,0),U)
+10 SET APCLPCNT=APCLPCNT+1
SET APCLPRNM(APCLPCNT)=APCLPRNT_" "_$$VD^APCLV(APCLVIEN,"S")
SET APCLPRNM(APCLPCNT,"I")=C
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
ADMWARD(V) ;EP return admission ward for this visit
+1 ;must be running PIMS
+2 ;
PN(V,R,I) ;EP
+1 NEW Y,N,Z,G,A
SET A=""
+2 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+3 SET N=$PIECE($GET(^AUPNVPOV(Y,0)),U,4)
+4 IF N=""
QUIT
+5 ;$P($G(^AUTNPOV(N,0)),U)
SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
+6 IF N=""
QUIT
+7 SET Z=0
FOR
SET Z=$ORDER(^APCLVRPT(R,11,I,11,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+8 SET G=$PIECE($GET(^APCLVRPT(R,11,I,11,Z,0)),U)
+9 IF N[G
SET A=1
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT A
EDOB(V,R,I) ;EP
+1 NEW Y,N,Z,G,A
SET A=""
+2 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPED("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+3 SET N=$PIECE($GET(^AUPNVPED(Y,0)),U,14)
+4 SET N=$$UP^XLFSTR(N)
+5 SET Z=0
FOR
SET Z=$ORDER(^APCLVRPT(R,11,I,11,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+6 SET G=$$UP^XLFSTR($PIECE($GET(^APCLVRPT(R,11,I,11,Z,0)),U))
+7 IF N[G
SET A=1
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT A
MCRD(P,D) ;is patient medicare eligible on this date
+1 NEW APCLMIFN,APCLFLG
+2 SET APCLFLG=0
+3 SET F=$GET(F)
+4 IF '$DATA(^DPT(P,0))
GOTO MCRX
+5 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+6 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+7 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+8 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+9 SET APCLMIFN=0
FOR
SET APCLMIFN=$ORDER(^AUPNMCR(P,11,APCLMIFN))
IF APCLMIFN'=+APCLMIFN
QUIT
Begin DoDot:1
+10 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U,3)'="D"
QUIT
+11 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U)>D
QUIT
+12 IF $PIECE(^AUPNMCR(P,11,APCLMIFN,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+13 SET APCLFLG=1
+14 QUIT
End DoDot:1
+15 IF APCLFLG
QUIT APCLFLG
+16 ;now check PI for D- or MD in 2nd piece of 2 node (per Shonda)
+17 ;check for D- in private insurer name
SET APCLFLG=$$PIDD^APCLOS21(DFN,D)
+18 QUIT APCLFLG
+19 ;
LASTINUD(P,D) ;EP - last date internet access was updated as of date D
+1 IF $GET(D)=""
SET D=DT
+2 IF '$GET(P)=""
QUIT ""
+3 IF '$DATA(^AUPNPAT(P,81))
QUIT ""
+4 NEW X,Y
+5 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNPAT(P,81,"B",X))
IF X'=+X!(X>D)
QUIT
SET Y=X
+6 QUIT Y
+7 ;
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
LASTINYN(P,F,D) ;EP - last response to does patient have internet access? as of date D
+1 IF '$GET(P)=""
QUIT ""
+2 IF $GET(D)=""
SET D=DT
+3 SET F=$GET(F)
+4 IF '$DATA(^AUPNPAT(P,81))
QUIT ""
+5 NEW X,Y,Z
+6 SET Z=""
+7 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNPAT(P,81,"B",X))
IF X'=+X!(X>D)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,81,"B",X,Y))
IF Y'=+Y
QUIT
SET Z=Y
+8 IF Z=""
QUIT Z
+9 IF F="I"
QUIT $PIECE(^AUPNPAT(P,81,Z,0),U,2)
+10 QUIT $$GET1^DIQ(9000001.81,Z_","_P_",",.02)
+11 ;
LASTINAC(P,F,D) ;EP - last response to does patient have internet access?
+1 ;as of date D
+2 IF '$GET(P)=""
QUIT ""
+3 SET F=$GET(F)
+4 SET D=$GET(D)
+5 IF D=""
SET D=DT
+6 IF '$DATA(^AUPNPAT(P,81))
QUIT ""
+7 NEW X,Y,Z
+8 SET Z=""
+9 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNPAT(P,81,"B",X))
IF X'=+X!(X>D)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,81,"B",X,Y))
IF Y'=+Y
QUIT
SET Z=Y
+10 IF Z=""
QUIT Z
+11 IF F="I"
QUIT $PIECE(^AUPNPAT(P,81,Z,0),U,3)
+12 QUIT $$GET1^DIQ(9000001.81,Z_","_P_",",.03)
+13 ;
MEDQD ;EP - return med/qty/days formatted
+1 NEW P,X,Q,D
+2 SET APCLPCNT=0
+3 SET P=0
FOR
SET P=$ORDER(^AUPNVMED("AD",APCLVIEN,P))
IF P'=+P
QUIT
Begin DoDot:1
+4 SET APCLPRNT=""
SET X=""
+5 SET X=$$RBLK^APCLUTL($EXTRACT($$VAL^XBDIQ1(9000010.14,P,.01),1,30),30)
+6 SET Q=$$RBLK^APCLUTL(" Qty: "_$PIECE(^AUPNVMED(P,0),U,6),13)
+7 SET D=" Days: "_$PIECE(^AUPNVMED(P,0),U,7)
+8 SET APCLPCNT=APCLPCNT+1
+9 SET APCLPRNM(APCLPCNT)=X_Q_D
+10 SET APCLPRNM(APCLPCNT,"I")=$PIECE(^AUPNVMED(P,0),U)
+11 QUIT
End DoDot:1
+12 QUIT
FAMHX ;EP - return FAMILY HISTORY AND RELATIONSHIP
+1 NEW P,X,Q,D
+2 SET APCLPCNT=0
+3 SET P=0
FOR
SET P=$ORDER(^AUPNFH("AC",DFN,P))
IF P'=+P
QUIT
Begin DoDot:1
+4 SET APCLPRNT=""
SET X=""
+5 SET X=$$VAL^XBDIQ1(9000014,P,.01)
+6 SET Q=$$VAL^XBDIQ1(9000014,P,.09)
+7 SET APCLPCNT=APCLPCNT+1
+8 SET APCLPRNM(APCLPCNT)=Q_" "_$$VAL^XBDIQ1(9000014.1,$PIECE(^AUPNFH(P,0),U,9),.03)_"; "_X
+9 ;S APCLPRNM(APCLPCNT,"I")=$P(^AUPNVMED(P,0),U)
+10 QUIT
End DoDot:1
+11 QUIT
FAMHXP ;EP - return FAMILY HISTORY DESCRIPTION
+1 NEW P,X,Q,D
+2 SET APCLPCNT=0
+3 SET P=0
FOR
SET P=$ORDER(^AUPNFH("AC",DFN,P))
IF P'=+P
QUIT
Begin DoDot:1
+4 SET APCLPRNT=""
SET X=""
+5 SET X=$$VAL^XBDIQ1(9000014,P,.01)
+6 SET Q=$$VAL^XBDIQ1(9000014,P,.09)
+7 SET APCLPCNT=APCLPCNT+1
+8 ;LORI MU
SET APCLPRNM(APCLPCNT)=Q_" "_$$VAL^XBDIQ1(9000014.1,$PIECE(^AUPNFH(P,0),U,9),.03)_"; "_X_"; "_$$VAL^XBDIQ1(9000014,P,.04)_"; Age at Onset: "_$$VAL^XBDIQ1(9000014,P,.05)
+9 ;S APCLPRNM(APCLPCNT,"I")=$P(^AUPNVMED(P,0),U)
+10 QUIT
End DoDot:1
+11 QUIT
ALLCPTS(V,RETVAL) ;EP - return in array RETVAL all cpts ien of visit V - used in VGEN
+1 NEW A,B,C,D
+2 SET C=0
+3 ;V CPT
+4 SET A=0
FOR
SET A=$ORDER(^AUPNVCPT("AD",V,A))
IF A'=+A
QUIT
IF $PIECE($GET(^AUPNVCPT(A,0)),U)
SET RETVAL($PIECE(^AUPNVCPT(A,0),U))=""
+5 ;V PROCEDURE
+6 SET A=0
FOR
SET A=$ORDER(^AUPNVPRC("AD",V,A))
IF A'=+A
QUIT
IF $PIECE($GET(^AUPNVPRC(A,0)),U,16)
SET RETVAL($PIECE(^AUPNVPRC(A,0),U,16))=""
+7 ;VISIT E&M
+8 SET A=$PIECE(^AUPNVSIT(V,0),U,17)
IF A
SET RETVAL(A)=""
+9 ;V TRAN CODES
+10 SET A=0
FOR
SET A=$ORDER(^AUPNVTC("AD",V,A))
IF A'=+A
QUIT
IF $PIECE($GET(^AUPNVTC(A,0)),U,7)
SET RETVAL($PIECE(^AUPNVTC(A,0),U,7))=""
+11 ;V PAT ED
+12 SET A=0
FOR
SET A=$ORDER(^AUPNVPED("AD",APCLVIEN,A))
IF A'=+A
QUIT
IF $PIECE($GET(^AUPNVPED(A,0)),U,9)
SET X($PIECE(^AUPNVPED(A,0),U,9))=""
+13 QUIT
ALLCPTSP(V,RETVAL) ;EP - return in array RETVAL all cpts ien of visit V - used in VGEN
+1 NEW A,B,C,D
+2 SET C=0
+3 ;V CPT
+4 SET A=0
FOR
SET A=$ORDER(^AUPNVCPT("AD",V,A))
IF A'=+A
QUIT
SET Z=$PIECE($GET(^AUPNVCPT(A,0)),U)
IF Z
SET C=C+1
SET RETVAL(C)=$$VAL^XBDIQ1(9000010.18,A,.01)
SET RETVAL(C,"I")=Z
+5 ;V PROCEDURE
+6 SET A=0
FOR
SET A=$ORDER(^AUPNVPRC("AD",V,A))
IF A'=+A
QUIT
SET Z=$PIECE($GET(^AUPNVPRC(A,0)),U,16)
IF Z
SET C=C+1
SET RETVAL(C)=$$VAL^XBDIQ1(9000010.08,A,.16)
SET RETVAL(C,"I")=Z
+7 ;VISIT E&M
+8 SET A=$PIECE(^AUPNVSIT(V,0),U,17)
IF A
SET C=C+1
SET RETVAL(C)=$$VAL^XBDIQ1(9000010,A,.17)
SET RETVAL(C,"I")=A
+9 ;V TRAN CODES
+10 SET A=0
FOR
SET A=$ORDER(^AUPNVTC("AD",V,A))
IF A'=+A
QUIT
SET Z=$$VALI^XBDIQ1(9000010.33,A,.07)
IF Z
SET C=C+1
SET RETVAL(C)=$$VAL^XBDIQ1(9000010.33,A,.07)
SET RETVAL(C,"I")=Z
+11 ;V PAT ED
+12 SET A=0
FOR
SET A=$ORDER(^AUPNVPED("AD",APCLVIEN,A))
IF A'=+A
QUIT
SET Z=$$VALI^XBDIQ1(9000010.16,A,.09)
IF Z
SET C=C+1
SET RETVAL(C)=$$VAL^XBDIQ1(9000010.16,A,.09)
SET RETVAL(C,"I")=Z
+13 QUIT
PMEAS ;
+1 NEW APCLX
+2 SET APCLX=0
FOR
SET APCLX=$ORDER(^AUPNVMSR("AD",APCLVIEN,APCLX))
IF APCLX'=+APCLX
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVMSR(APCLX,2)),U)
QUIT
+4 SET APCLPRNT=$$VAL^XBDIQ1(9000010.01,APCLX,.01)
+5 SET APCLPCNT=APCLPCNT+1
+6 ;$P(^AUPNVMSR(APCLX,0),U,4)
SET APCLPRNM(APCLPCNT)=APCLPRNT_" "_$$R($$VAL^XBDIQ1(9000010.01,APCLX,.01),$$VAL^XBDIQ1(9000010.01,APCLX,.04))
+7 SET APCLPRNM(APCLPCNT,"I")=$PIECE(^AUPNVMSR(APCLX,0),U)
+8 QUIT
End DoDot:1
+9 QUIT
R(T,V) ;
+1 IF T'="HT"
IF T'="WT"
IF T'="BMI"
QUIT V
+2 IF V'["."
QUIT V
+3 QUIT $TRANSLATE($JUSTIFY(V,7,2)," ")
