APCLSIL2 ; IHS/CMI/LAB - H1N1 SURVEILLANCE EXPORT ; 28 Oct 2014 4:58 PM
;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28,29,30,31**;FEB 05, 1997;Build 32
;
;
SETREC ;EP - called from
S C=","
S APCLREC=$$UID(DFN)
S $P(APCLREC,",",2)=$S($$HRN^AUPNPAT(DFN,APCLLOC)]"":$$HRN^AUPNPAT(DFN,APCLLOC),1:$$HRN^AUPNPAT(DFN,DUZ(2)))
S $P(APCLREC,",",3)=$P(^DPT(DFN,0),U,2)
S $P(APCLREC,",",4)=$P(^DPT(DFN,0),U,3)
S $P(APCLREC,",",5)=$$COMMRES^AUPNPAT(DFN,"C")
S $P(APCLREC,",",6)=$P(^AUTTLOC(APCLLOC,0),U,10)
S $P(APCLREC,",",7)=APCLDATE
;povs
S X=0,APCLC=7 S Y=$P(APCLILI,U,2,99) F X=1:1 S Z=$P(Y,U,X) Q:APCLC>9!(Z="") I Z]"" S APCLC=APCLC+1,$P(APCLREC,",",APCLC)=Z
S APCLTEMP=""
S X=0 F S X=$O(^AUPNVMSR("AD",APCLV,X)) Q:X'=+X D
.Q:$P($G(^AUPNVMSR(X,2)),U,1)
.Q:$$VAL^XBDIQ1(9000010.01,X,.01)'="TMP"
.S V=$P(^AUPNVMSR(X,0),U,4)
.S APCLTEMP=$S(V>APCLTEMP:V,1:APCLTEMP)
.S $P(APCLREC,",",11)="TMP^"_APCLTEMP_"^"_$$VD^APCLV(APCLV)
S $P(APCLREC,",",12)=$S($P($G(^AUPNVSIT(APCLV,11)),U,14)]"":$P($G(^AUPNVSIT(APCLV,11)),U,14),1:$$UIDV^AUPNVSIT(APCLV))
S $P(APCLREC,",",14)=$P(^AUPNVSIT(APCLV,0),U,13)
S $P(APCLREC,",",15)=$P(^AUPNVSIT(APCLV,0),U,7)
S $P(APCLREC,",",16)=$$DSCHTYPE(APCLV)
S $P(APCLREC,",",17)=$$DSCHDATE(APCLV)
S APCLREF="" I APCLH1N1!(APCLILI) S APCLREF=$$REF(APCLV) D
.S $P(APCLREC,",",18)=$P(APCLREF,U)
.S $P(APCLREC,",",19)=$P(APCLREF,U,2)
S $P(APCLREC,",",21)=$P(APCLHVAC,U,2)
S $P(APCLREC,",",22)=$P(APCLIVAC,U,2)
S APCLASDM=$$ASTDM(DFN,$$VD^APCLV(APCLV))
S $P(APCLREC,",",33)=$P(APCLASDM,U,1)
S $P(APCLREC,",",34)=$P(APCLASDM,U,2)
S APCLPN=$$PN^APCLSIL1(DFN,APCLV)
S $P(APCLREC,",",36)=APCLPN
S APCLBMI="" I APCLPN'="Y" S APCLBMI=$$BMI(DFN,$$VD^APCLV(APCLV))
I APCLPN'="Y" S $P(APCLREC,",",35)=$$OB(DFN,$P(APCLBMI,U,1),$$AGE^AUPNPAT(DFN,$P(APCLBMI,U,6)))
S $P(APCLREC,",",37)=$$R($P(APCLBMI,U,1))
S $P(APCLREC,",",38)=$P(APCLBMI,U,6)
S %=$$PNEU(DFN,DT)
S $P(APCLREC,",",39)=$P(%,U,2)
S $P(APCLREC,",",40)=$P(%,U,1)
S $P(APCLREC,",",41)=$$CLINIC^APCLV(APCLV,"C")
S $P(APCLREC,",",43)=$P(APCLH1N1,U,2)
S $P(APCLREC,",",45)=$P(APCLSRD,U,2)
S $P(APCLREC,",",46)=$P(APCLSRD,U,3)
S $P(APCLREC,",",47)=$P(APCLSRD,U,4)
S $P(APCLREC,",",48)=$P(APCLSRD,U,5)
S $P(APCLREC,",",59)=$$STRIP^XLFSTR($P(APCLAVM,U,2),",")
S $P(APCLREC,",",60)=$$STRIP^XLFSTR($P(APCLAVM,U,3),",")
S $P(APCLREC,",",61)=$$STRIP^XLFSTR($P(APCLHVAC,U,3),",")
S $P(APCLREC,",",62)=$$STRIP^XLFSTR($P(APCLHVAC,U,4),",")
S $P(APCLREC,",",63)="p31" ;IHS/CMI/LAB - PATCH 31 06/14/17
S $P(APCLREC,",",64)=$$STRIP^XLFSTR($P(APCLIVAC,U,3),",")
S $P(APCLREC,",",65)=$$STRIP^XLFSTR($P(APCLIVAC,U,4),",")
S $P(APCLREC,",",66)=$P(APCLADVE,U,2)
S $P(APCLREC,",",71)=$P(APCLOVAC,",",1,36)
S $P(APCLREC,",",107)=$P(APCLPVAC,U,2)
S $P(APCLREC,",",108)=$P(APCLADVE,U,3)
S $P(APCLREC,",",113)=APCLPCVF
S $P(APCLREC,",",115)=APCLPCVE
S $P(APCLREC,",",117)=APCLPCVA
S $P(APCLREC,",",119)=APCLPCVS
S $P(APCLREC,",",121)=APCLPCVI
I APCLIVAC S $P(APCLREC,",",123)=APCLDATE
I APCLHVAC S $P(APCLREC,",",124)=APCLDATE
D
.;PER EMAIL, USE WT AND HT FROM THE BMI CALCULATION, IF NO BMI USE MOST RECENT WT AND HT ON OR BEFORE VISIT DATE
.I $P(APCLBMI,U,5)]"" S $P(APCLREC,",",125)="WT^"_$P(APCLBMI,U,5)_U_$P(APCLBMI,U,6) Q
.S X=$$LASTITEM^APCLAPIU(DFN,"WT","MEASUREMENT",,$$VD^APCLV(APCLV),"A") I X]"" S $P(APCLREC,",",125)="WT^"_$P(X,U,3)_U_$P(X,U,1)
D
.I $P(APCLBMI,U,2)]"" S $P(APCLREC,",",126)="HT^"_$P(APCLBMI,U,2)_U_$P(APCLBMI,U,3) Q
.S X=$$LASTITEM^APCLAPIU(DFN,"HT","MEASUREMENT",,$$VD^APCLV(APCLV),"A") I X]"" S $P(APCLREC,",",126)="HT^"_$P(X,U,3)_U_$P(X,U,1)
S $P(APCLREC,",",132)=APCLSTAT ;status
S $P(APCLREC,",",133)=$P(APCLNVAC,U,2)
S $P(APCLREC,",",134)=$$STRIP^XLFSTR($P(APCLNVAC,U,3),",")
S $P(APCLREC,",",135)=$$STRIP^XLFSTR($P(APCLNVAC,U,4),",")
I APCLNVAC S $P(APCLREC,",",136)=APCLDATE
S $P(APCLREC,",",138)=$$PRIMPROV^APCLV(APCLV,"I")
S APCLVTOT=APCLVTOT+1
S ^APCLDATA($J,APCLVTOT)=APCLREC
;NOW SET NEW LOG ENTRY
I '$D(^APCLILIL("B",APCLV)) D
.S DIC="^APCLILIL(",DIC(0)="L",DIADD=1,DLAYGO=9001003.4,X=APCLV,DINUM=X K DD,D0,DO D FILE^DICN K DIC,DIADD,DLAYGO,DINUM
N APCLFDA,APCLIENS,APCLERRR
S APCLIENS=""
S APCLFDA(9001003.4,APCLV_",",.02)=APCLZHSD
S APCLFDA(9001003.411,"+2,"_APCLV_",",.01)=APCLZHSD
S APCLFDA(9001003.411,"+2,"_APCLV_",",.02)=APCLSTAT
S APCLFDA(9001003.411,"+2,"_APCLV_",",.03)=APCLREAS
D UPDATE^DIE("","APCLFDA","APCLIENS","APCLERRR(1)")
Q
PNEU(P,EDATE) ;EP
I $G(P)="" Q ""
NEW V,X,Y,F,I,APCLLAST,T,X,BDATE,CVX,T1
S APCLLAST="",V=""
S BDATE=$$DOB^AUPNPAT(P)
S T=$O(^ATXAX("B","SURVEILLANCE PNEUMO CVX CODES",0))
S T1=$O(^ATXAX("B","BGP PNEUMO IZ CVX CODES",0))
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNVIMM(X,0)),U,1)
.I 'I Q
.S CVX=$P($G(^AUTTIMM(I,0)),U,3)
.Q:CVX=""
.I '$D(^ATXAX(T,21,"B",CVX)),'$D(^ATXAX(T1,21,"B",CVX)) Q ;NOT IN TAXONOMY
.S D=$P($$VALI^XBDIQ1(9000010.11,X,1201),".")
.I D="" S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
.Q:D<BDATE
.Q:D>EDATE
.S V=D_U_"IMMUNIZATION"_U_CVX
.D E
S V=$$LASTITEM^APCLAPIU(P,"[BGP PNEUMO IZ DXS","DX",$S($P(APCLLAST,U)]"":$P(APCLLAST,U),1:$$DOB^AUPNPAT(P)),EDATE,"A")
I V]"" S V=$P(V,U,1)_U_"DX"_U_$$VAL^XBDIQ1($P(V,U,5),$P(V,U,6),.01)
D E
S V=$$LASTCPTT^APCLAPIU(P,$S($P(APCLLAST,U)]"":$P(APCLLAST,U),1:$$DOB^AUPNPAT(P)),EDATE,"BGP PNEUMO IZ CPTS","A")
I V]"" S %=$P(V,U,1)_U_"CPT"_U_$$VAL^XBDIQ1($P(V,U,5),$P(V,U,6),.01),V=%
D E
Q $P(APCLLAST,U,1)_U_$P(APCLLAST,U,3)
;
E ;
I $P(V,U,1)>$P(APCLLAST,U,1) S APCLLAST=V
Q
;
OB(P,BMI,A) ;EP obese
NEW S,R
I $G(BMI)="" Q ""
S S=$P(^DPT(P,0),U,2)
I S="" Q ""
S R=0,R=$O(^APCLBMI("H",S,A,R))
I 'R S R=$O(^APCLBMI("H",S,A)) I R S R=$O(^APCLBMI("H",S,R,""))
I 'R Q ""
I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q ""
I BMI'<$P(^APCLBMI(R,0),U,5) Q "Y"
Q ""
R(V) ;EP
I $G(V)="" Q ""
I $L($P(V,".",2))<3 Q V
S V=V+.005
Q $P(V,".",1)_"."_$E($P(V,".",2),1,2)
BMI(P,EDATE) ;EP - get last calulable bmi as of EDATE and date of wt
;return value: will be a "^" pieced string with the following pieces:
; 1 - BMI value (not rounded)
; 2 - HT value used (not rounded)
; 3 - Date of HT value used in internal fileman format
; 4 - visit ien of visit on which HT found
; 5 - WT used (not rounded)
; 6 - date of weight used
; 7 - visit ien of visit on which weight found
;
;NOTE: any weight taken on a prenatal visit is excluded and a prior weight is used
;NOTE: if you add warnings, please use the word WARNING (caps) in the error message
;NOTE: pts <18 must have ht/wt on same day and within past year
; pts >50 must have ht/wt within past 2 years
; pts 19-50 must have ht/wt within past5 years
;
NEW %,W,H,B,D,%DT,BDATE,AGE,WD,HD,VALUE,V,ERRC,ERR,BMI,CD,WD,HD,WV,HV,OW,OH
S ERRC=0
S VALUE=""
I $G(EDATE)="" S EDATE=DT
I $G(P)="" Q "^^^^^^^PATIENT DFN INVALID"
I '$D(^AUPNPAT(P,0)) Q "^^^^^^^PATIENT DFN INVALID"
I '$D(^DPT(P,0)) Q "^^^^^^^PATIENT DFN INVALID"
S AGE=$$AGE^AUPNPAT(P,EDATE)
S VALUE=""
I AGE>18,AGE<50 D Q VALUE
.S BDATE=$$FMADD^XLFDT(EDATE,-(5*365)) ;5 yrs
.S EDATE=$$FMTE^XLFDT(EDATE)
.;get last weight on file
.S V=$$WT(P,BDATE,EDATE)
.S (W,OW)=$P(V,U,1)
.I W=""!(W="?") S ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S WD=$P(V,U,2)
.S WV=$P(V,U,3)
.S V=$$HT(P,BDATE,EDATE)
.S (H,OH)=$P(V,U,1)
.I H="" S ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S HD=$P(V,U,2)
.S HV=$P(V,U,3)
.S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
.D SETV
I AGE>49 D Q VALUE
.S BDATE=$$FMADD^XLFDT(EDATE,-(2*365)) ;2 yrs
.S EDATE=$$FMTE^XLFDT(EDATE)
.;get last weight on file
.S V=$$WT(P,BDATE,EDATE)
.S (W,OW)=$P(V,U,1)
.I W=""!(W="?") S ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S WD=$P(V,U,2) ;weight date
.S WV=$P(V,U,3)
.S V=$$HT(P,BDATE,EDATE)
.S (H,OH)=$P(V,U,1)
.I H="" S ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S HD=$P(V,U,2)
.S HV=$P(V,U,3)
.S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
.D SETV
.Q
I AGE<19 D Q VALUE
.S BDATE=$$FMADD^XLFDT(EDATE,-365)
.S EDATE=$$FMTE^XLFDT(EDATE)
.S X=$$HTWTSD(P,BDATE,EDATE)
.I '$P(X,"^") S ERR="NO WEIGHT FOUND ON SAME DAY AS HT ON OR PRIOR TO "_EDATE D ERR Q
.I '$P(X,"^",4) S ERR="NO HEIGHT FOUND ON SAME DAY AS WT ON OR PRIOR TO "_EDATE D ERR Q
.S (W,OW)=$P(X,"^")
.S (H,OH)=$P(X,"^",4)
.S WD=$P(X,U,2)
.S WV=$P(X,U,3)
.S HD=$P(X,U,5)
.S HV=$P(X,U,6)
.S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
.D SETV
.Q
Q
HTWTSD(P,BDATE,EDATE) ;EP - get last ht / wt on same day
I '$G(P) Q ""
NEW APCLWTS,APCLHTS,%,X,APCLWTS1,APCLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"APCLHTS(")
S Y=0 F S Y=$O(APCLHTS(Y)) Q:Y'=+Y I $P(APCLHTS(Y),U,2)="?"!($P(APCLHTS(Y),U,2)="") K APCLHTS(Y)
K APCLHTS1 S X=0 F S X=$O(APCLHTS(X)) Q:X'=+X S APCLHTS1($P(APCLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"APCLWTS(")
S Y=0 F S Y=$O(APCLWTS(Y)) Q:Y'=+Y I $P(APCLWTS(Y),U,2)="?"!($P(APCLWTS(Y),U,2)="") K APCLWTS(Y)
;set the array up by date
K APCLWTS1 S X=0 F S X=$O(APCLWTS(X)) Q:X'=+X S APCLWTS1($P(APCLWTS(X),U))=X
S APCLCHT="",X=9999999 F S X=$O(APCLWTS1(X),-1) Q:X=""!(APCLCHT]"") I $D(APCLHTS1(X)) D
.S APCLCHT=$P(APCLWTS(APCLWTS1(X)),U,2)_U_$P(APCLWTS(APCLWTS1(X)),U,1)_U_$P(APCLWTS(APCLWTS1(X)),U,5)_U_$P(APCLHTS(APCLHTS1(X)),U,2)_U_$P(APCLHTS(APCLHTS1(X)),U,1)_U_$P(APCLHTS(APCLHTS1(X)),U,5)
Q APCLCHT
;
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,APCLARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"APCLARRY(")
S H=$P($G(APCLARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
S H=H_U_$P(APCLARRY(1),U,1)_U_$P(APCLARRY(1),U,5)
Q H
;
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,APCLLW,X,APCLLN,APCLL,APCLLD,APCLLZ,APCLLX,APCLICD
K APCLL S APCLLW="" S APCLLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(APCLLX,"APCLL(")
S APCLLN=0 F S APCLLN=$O(APCLL(APCLLN)) Q:APCLLN'=+APCLLN!(APCLLW]"") D
.S APCLLZ=$P(APCLL(APCLLN),U,5)
.I '$D(^AUPNVPOV("AD",APCLLZ)) S APCLLW=$P(APCLL(APCLLN),U,2)_U_$P(APCLL(APCLLN),U,1)_U_$P(APCLL(APCLLN),U,5) Q
. S APCLLD=0 F S APCLLD=$O(^AUPNVPOV("AD",APCLLZ,APCLLD)) Q:'APCLLD!(APCLLW]"") D
.. S APCLICD=$P($$ICDDX^APCLSILU($P(^AUPNVPOV(APCLLD,0),U)),U,2) D
...Q:$$ICD^APCLSILU(APCLICD,$O(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0)),9)
...S APCLLW=$P(APCLL(APCLLN),U,2)_U_$P(APCLL(APCLLN),U,1)_U_$P(APCLL(APCLLN),U,5)
..Q
Q APCLLW
;
ERR ;EP
S ERRC=ERRC+1
NEW C
S C=$P(VALUE,U,8)
S $P(C,"|",ERRC)=ERR
S $P(VALUE,U,8)=C
Q
;
SETV ;EP
S $P(VALUE,U,1)=BMI
S $P(VALUE,U,2)=OH
S $P(VALUE,U,3)=HD
S $P(VALUE,U,4)=HV
S $P(VALUE,U,5)=OW
S $P(VALUE,U,6)=WD
S $P(VALUE,U,7)=WV
Q
;
ASTDM(P,EDATE) ;EP
;asthma active problem list
NEW X,Y,Q,G,T,APCL,%,E,V,TD,APCLAS,APCLDM,APCLDMC,APCLASC
S APCLAS="",APCLDM="",APCLASC=0,APCLDMC=0
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
S TD=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
S G=""
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $P(^AUPNPROB(X,0),U,8)>EDATE Q
.S Q=$P(^AUPNPROB(X,0),U)
.I $$ICD^APCLSILU(Q,T,9) S APCLAS="Y" Q
.I $$ICD^APCLSILU(Q,TD,9) S APCLDM="Y" Q
I APCLAS]"",APCLDM]"" Q APCLAS_U_APCLDM
;now for 2 povs on 2 different days, primary dx only, aorsh only
D ALLV^APCLAPIU(P,,EDATE,"APCL")
I '$D(APCL) Q APCLAS_U_APCLDM
;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma OR DM
NEW APCLJ,APCLK
S X=0 F S X=$O(APCL(X)) Q:X'=+X!(APCLAS]""&(APCLDM]"")) D
.S V=$P(APCL(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:"AORSH"'[$P(^AUPNVSIT(V,0),U,7)
.S Q=$$PRIMPOV^APCLV(V,"I")
.Q:Q="" ;no primary dx
.I $$ICD^APCLSILU(Q,T,9),'$D(APCLJ($P(APCL(X),U,1))) S APCLJ($P(APCL(X),U,1))="",APCLASC=APCLASC+1 I APCLASC>1 S APCLAS="Y" ;not in taxonomy
.I $$ICD^APCLSILU(Q,TD,9),'$D(APCLK($P(APCL(X),U,1))) S APCLK($P(APCL(X),U,1))="",APCLDMC=APCLDMC+1 I APCLDMC>1 S APCLDM="Y" ;not in taxonomy
.Q
Q APCLAS_U_APCLDM
REF(V) ;EP
;is there a referral with a referral date of the visit date or 1 day later
NEW B,E,X,Y,Z,P,C
S C=""
S B=$P($P(^AUPNVSIT(V,0),U),".")
S E=$$FMADD^XLFDT($S($P(^AUPNVSIT(V,0),U,7)="H":$$DSCHDATE(V),1:B),1)
S P=$P(^AUPNVSIT(V,0),U,5)
S X=0 F S X=$O(^BMCREF("D",P,X)) Q:X'=+X D
.S D=$P($G(^BMCREF(X,0)),U,1)
.Q:D=""
.I D<B Q
.I D>E Q
.I $P(^BMCREF(X,0),U,14)'="I"
.S C="Y"_U_D
.Q
Q C
;
DSCHTYPE(V) ;EP
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
NEW %,Y,Z
I $P(^AUPNVSIT(V,0),"^",3)="C" G CHSDT
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q Z
S Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
I 'Y Q ""
I $P(^DD(9000010.02,.06,0),"^",2)[42.2 Q $P($G(^DIC(42.2,Y,0)),"^")
I $P(^DD(9000010.02,.06,0),"^",2)[405.1 Q $P($G(^DG(405.1,Y,0)),"^")
Q ""
CHSDT ;
S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q ""
S Y=$$VAL^XBDIQ1(9000010.03,Z,.08)
Q Y
DSCHDATE(V) ;EP
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $P(^AUPNVSIT(V,0),"^",7)'="H" Q ""
NEW Y,Z
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z G CHSDD
S Y=$P(^AUPNVINP(Z,0),"^")
I Y="" Q Y
Q $P(Y,".")
CHSDD ;
S Z=$O(^AUPNVCHS("AD",V,0)) I 'Z Q Z
S Y=$P(^AUPNVCHS(Z,0),"^",7)
I Y="" Q Y
Q $P(Y,".")
;
DATE(D) ;
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
;
JDATE(D) ;EP
I $G(D)="" Q ""
NEW A
S A=$$FMTE^XLFDT(D)
Q $E(D,6,7)_$$UP^XLFSTR($P(A," ",1))_(1700+$E(D,1,3))
;
UID(APCLA) ;Given DFN return unique patient record id.
I '$G(APCLA) Q ""
I '$D(^AUPNPAT(APCLA)) Q ""
;
Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(APCLA))_APCLA
;
APCLSIL2 ; IHS/CMI/LAB - H1N1 SURVEILLANCE EXPORT ; 28 Oct 2014 4:58 PM
+1 ;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28,29,30,31**;FEB 05, 1997;Build 32
+2 ;
+3 ;
SETREC ;EP - called from
+1 SET C=","
+2 SET APCLREC=$$UID(DFN)
+3 SET $PIECE(APCLREC,",",2)=$SELECT($$HRN^AUPNPAT(DFN,APCLLOC)]"":$$HRN^AUPNPAT(DFN,APCLLOC),1:$$HRN^AUPNPAT(DFN,DUZ(2)))
+4 SET $PIECE(APCLREC,",",3)=$PIECE(^DPT(DFN,0),U,2)
+5 SET $PIECE(APCLREC,",",4)=$PIECE(^DPT(DFN,0),U,3)
+6 SET $PIECE(APCLREC,",",5)=$$COMMRES^AUPNPAT(DFN,"C")
+7 SET $PIECE(APCLREC,",",6)=$PIECE(^AUTTLOC(APCLLOC,0),U,10)
+8 SET $PIECE(APCLREC,",",7)=APCLDATE
+9 ;povs
+10 SET X=0
SET APCLC=7
SET Y=$PIECE(APCLILI,U,2,99)
FOR X=1:1
SET Z=$PIECE(Y,U,X)
IF APCLC>9!(Z="")
QUIT
IF Z]""
SET APCLC=APCLC+1
SET $PIECE(APCLREC,",",APCLC)=Z
+11 SET APCLTEMP=""
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",APCLV,X))
IF X'=+X
QUIT
Begin DoDot:1
+13 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+14 IF $$VAL^XBDIQ1(9000010.01,X,.01)'="TMP"
QUIT
+15 SET V=$PIECE(^AUPNVMSR(X,0),U,4)
+16 SET APCLTEMP=$SELECT(V>APCLTEMP:V,1:APCLTEMP)
+17 SET $PIECE(APCLREC,",",11)="TMP^"_APCLTEMP_"^"_$$VD^APCLV(APCLV)
End DoDot:1
+18 SET $PIECE(APCLREC,",",12)=$SELECT($PIECE($GET(^AUPNVSIT(APCLV,11)),U,14)]"":$PIECE($GET(^AUPNVSIT(APCLV,11)),U,14),1:$$UIDV^AUPNVSIT(APCLV))
+19 SET $PIECE(APCLREC,",",14)=$PIECE(^AUPNVSIT(APCLV,0),U,13)
+20 SET $PIECE(APCLREC,",",15)=$PIECE(^AUPNVSIT(APCLV,0),U,7)
+21 SET $PIECE(APCLREC,",",16)=$$DSCHTYPE(APCLV)
+22 SET $PIECE(APCLREC,",",17)=$$DSCHDATE(APCLV)
+23 SET APCLREF=""
IF APCLH1N1!(APCLILI)
SET APCLREF=$$REF(APCLV)
Begin DoDot:1
+24 SET $PIECE(APCLREC,",",18)=$PIECE(APCLREF,U)
+25 SET $PIECE(APCLREC,",",19)=$PIECE(APCLREF,U,2)
End DoDot:1
+26 SET $PIECE(APCLREC,",",21)=$PIECE(APCLHVAC,U,2)
+27 SET $PIECE(APCLREC,",",22)=$PIECE(APCLIVAC,U,2)
+28 SET APCLASDM=$$ASTDM(DFN,$$VD^APCLV(APCLV))
+29 SET $PIECE(APCLREC,",",33)=$PIECE(APCLASDM,U,1)
+30 SET $PIECE(APCLREC,",",34)=$PIECE(APCLASDM,U,2)
+31 SET APCLPN=$$PN^APCLSIL1(DFN,APCLV)
+32 SET $PIECE(APCLREC,",",36)=APCLPN
+33 SET APCLBMI=""
IF APCLPN'="Y"
SET APCLBMI=$$BMI(DFN,$$VD^APCLV(APCLV))
+34 IF APCLPN'="Y"
SET $PIECE(APCLREC,",",35)=$$OB(DFN,$PIECE(APCLBMI,U,1),$$AGE^AUPNPAT(DFN,$PIECE(APCLBMI,U,6)))
+35 SET $PIECE(APCLREC,",",37)=$$R($PIECE(APCLBMI,U,1))
+36 SET $PIECE(APCLREC,",",38)=$PIECE(APCLBMI,U,6)
+37 SET %=$$PNEU(DFN,DT)
+38 SET $PIECE(APCLREC,",",39)=$PIECE(%,U,2)
+39 SET $PIECE(APCLREC,",",40)=$PIECE(%,U,1)
+40 SET $PIECE(APCLREC,",",41)=$$CLINIC^APCLV(APCLV,"C")
+41 SET $PIECE(APCLREC,",",43)=$PIECE(APCLH1N1,U,2)
+42 SET $PIECE(APCLREC,",",45)=$PIECE(APCLSRD,U,2)
+43 SET $PIECE(APCLREC,",",46)=$PIECE(APCLSRD,U,3)
+44 SET $PIECE(APCLREC,",",47)=$PIECE(APCLSRD,U,4)
+45 SET $PIECE(APCLREC,",",48)=$PIECE(APCLSRD,U,5)
+46 SET $PIECE(APCLREC,",",59)=$$STRIP^XLFSTR($PIECE(APCLAVM,U,2),",")
+47 SET $PIECE(APCLREC,",",60)=$$STRIP^XLFSTR($PIECE(APCLAVM,U,3),",")
+48 SET $PIECE(APCLREC,",",61)=$$STRIP^XLFSTR($PIECE(APCLHVAC,U,3),",")
+49 SET $PIECE(APCLREC,",",62)=$$STRIP^XLFSTR($PIECE(APCLHVAC,U,4),",")
+50 ;IHS/CMI/LAB - PATCH 31 06/14/17
SET $PIECE(APCLREC,",",63)="p31"
+51 SET $PIECE(APCLREC,",",64)=$$STRIP^XLFSTR($PIECE(APCLIVAC,U,3),",")
+52 SET $PIECE(APCLREC,",",65)=$$STRIP^XLFSTR($PIECE(APCLIVAC,U,4),",")
+53 SET $PIECE(APCLREC,",",66)=$PIECE(APCLADVE,U,2)
+54 SET $PIECE(APCLREC,",",71)=$PIECE(APCLOVAC,",",1,36)
+55 SET $PIECE(APCLREC,",",107)=$PIECE(APCLPVAC,U,2)
+56 SET $PIECE(APCLREC,",",108)=$PIECE(APCLADVE,U,3)
+57 SET $PIECE(APCLREC,",",113)=APCLPCVF
+58 SET $PIECE(APCLREC,",",115)=APCLPCVE
+59 SET $PIECE(APCLREC,",",117)=APCLPCVA
+60 SET $PIECE(APCLREC,",",119)=APCLPCVS
+61 SET $PIECE(APCLREC,",",121)=APCLPCVI
+62 IF APCLIVAC
SET $PIECE(APCLREC,",",123)=APCLDATE
+63 IF APCLHVAC
SET $PIECE(APCLREC,",",124)=APCLDATE
+64 Begin DoDot:1
+65 ;PER EMAIL, USE WT AND HT FROM THE BMI CALCULATION, IF NO BMI USE MOST RECENT WT AND HT ON OR BEFORE VISIT DATE
+66 IF $PIECE(APCLBMI,U,5)]""
SET $PIECE(APCLREC,",",125)="WT^"_$PIECE(APCLBMI,U,5)_U_$PIECE(APCLBMI,U,6)
QUIT
+67 SET X=$$LASTITEM^APCLAPIU(DFN,"WT","MEASUREMENT",,$$VD^APCLV(APCLV),"A")
IF X]""
SET $PIECE(APCLREC,",",125)="WT^"_$PIECE(X,U,3)_U_$PIECE(X,U,1)
End DoDot:1
+68 Begin DoDot:1
+69 IF $PIECE(APCLBMI,U,2)]""
SET $PIECE(APCLREC,",",126)="HT^"_$PIECE(APCLBMI,U,2)_U_$PIECE(APCLBMI,U,3)
QUIT
+70 SET X=$$LASTITEM^APCLAPIU(DFN,"HT","MEASUREMENT",,$$VD^APCLV(APCLV),"A")
IF X]""
SET $PIECE(APCLREC,",",126)="HT^"_$PIECE(X,U,3)_U_$PIECE(X,U,1)
End DoDot:1
+71 ;status
SET $PIECE(APCLREC,",",132)=APCLSTAT
+72 SET $PIECE(APCLREC,",",133)=$PIECE(APCLNVAC,U,2)
+73 SET $PIECE(APCLREC,",",134)=$$STRIP^XLFSTR($PIECE(APCLNVAC,U,3),",")
+74 SET $PIECE(APCLREC,",",135)=$$STRIP^XLFSTR($PIECE(APCLNVAC,U,4),",")
+75 IF APCLNVAC
SET $PIECE(APCLREC,",",136)=APCLDATE
+76 SET $PIECE(APCLREC,",",138)=$$PRIMPROV^APCLV(APCLV,"I")
+77 SET APCLVTOT=APCLVTOT+1
+78 SET ^APCLDATA($JOB,APCLVTOT)=APCLREC
+79 ;NOW SET NEW LOG ENTRY
+80 IF '$DATA(^APCLILIL("B",APCLV))
Begin DoDot:1
+81 SET DIC="^APCLILIL("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9001003.4
SET X=APCLV
SET DINUM=X
KILL DD,D0,DO
DO FILE^DICN
KILL DIC,DIADD,DLAYGO,DINUM
End DoDot:1
+82 NEW APCLFDA,APCLIENS,APCLERRR
+83 SET APCLIENS=""
+84 SET APCLFDA(9001003.4,APCLV_",",.02)=APCLZHSD
+85 SET APCLFDA(9001003.411,"+2,"_APCLV_",",.01)=APCLZHSD
+86 SET APCLFDA(9001003.411,"+2,"_APCLV_",",.02)=APCLSTAT
+87 SET APCLFDA(9001003.411,"+2,"_APCLV_",",.03)=APCLREAS
+88 DO UPDATE^DIE("","APCLFDA","APCLIENS","APCLERRR(1)")
+89 QUIT
PNEU(P,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW V,X,Y,F,I,APCLLAST,T,X,BDATE,CVX,T1
+3 SET APCLLAST=""
SET V=""
+4 SET BDATE=$$DOB^AUPNPAT(P)
+5 SET T=$ORDER(^ATXAX("B","SURVEILLANCE PNEUMO CVX CODES",0))
+6 SET T1=$ORDER(^ATXAX("B","BGP PNEUMO IZ CVX CODES",0))
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET I=$PIECE($GET(^AUPNVIMM(X,0)),U,1)
+9 IF 'I
QUIT
+10 SET CVX=$PIECE($GET(^AUTTIMM(I,0)),U,3)
+11 IF CVX=""
QUIT
+12 ;NOT IN TAXONOMY
IF '$DATA(^ATXAX(T,21,"B",CVX))
IF '$DATA(^ATXAX(T1,21,"B",CVX))
QUIT
+13 SET D=$PIECE($$VALI^XBDIQ1(9000010.11,X,1201),".")
+14 IF D=""
SET D=$$VD^APCLV($PIECE(^AUPNVIMM(X,0),U,3))
+15 IF D<BDATE
QUIT
+16 IF D>EDATE
QUIT
+17 SET V=D_U_"IMMUNIZATION"_U_CVX
+18 DO E
End DoDot:1
+19 SET V=$$LASTITEM^APCLAPIU(P,"[BGP PNEUMO IZ DXS","DX",$SELECT($PIECE(APCLLAST,U)]"":$PIECE(APCLLAST,U),1:$$DOB^AUPNPAT(P)),EDATE,"A")
+20 IF V]""
SET V=$PIECE(V,U,1)_U_"DX"_U_$$VAL^XBDIQ1($PIECE(V,U,5),$PIECE(V,U,6),.01)
+21 DO E
+22 SET V=$$LASTCPTT^APCLAPIU(P,$SELECT($PIECE(APCLLAST,U)]"":$PIECE(APCLLAST,U),1:$$DOB^AUPNPAT(P)),EDATE,"BGP PNEUMO IZ CPTS","A")
+23 IF V]""
SET %=$PIECE(V,U,1)_U_"CPT"_U_$$VAL^XBDIQ1($PIECE(V,U,5),$PIECE(V,U,6),.01)
SET V=%
+24 DO E
+25 QUIT $PIECE(APCLLAST,U,1)_U_$PIECE(APCLLAST,U,3)
+26 ;
E ;
+1 IF $PIECE(V,U,1)>$PIECE(APCLLAST,U,1)
SET APCLLAST=V
+2 QUIT
+3 ;
OB(P,BMI,A) ;EP obese
+1 NEW S,R
+2 IF $GET(BMI)=""
QUIT ""
+3 SET S=$PIECE(^DPT(P,0),U,2)
+4 IF S=""
QUIT ""
+5 SET R=0
SET R=$ORDER(^APCLBMI("H",S,A,R))
+6 IF 'R
SET R=$ORDER(^APCLBMI("H",S,A))
IF R
SET R=$ORDER(^APCLBMI("H",S,R,""))
+7 IF 'R
QUIT ""
+8 IF BMI>$PIECE(^APCLBMI(R,0),U,7)!(BMI<$PIECE(^APCLBMI(R,0),U,6))
QUIT ""
+9 IF BMI'<$PIECE(^APCLBMI(R,0),U,5)
QUIT "Y"
+10 QUIT ""
R(V) ;EP
+1 IF $GET(V)=""
QUIT ""
+2 IF $LENGTH($PIECE(V,".",2))<3
QUIT V
+3 SET V=V+.005
+4 QUIT $PIECE(V,".",1)_"."_$EXTRACT($PIECE(V,".",2),1,2)
BMI(P,EDATE) ;EP - get last calulable bmi as of EDATE and date of wt
+1 ;return value: will be a "^" pieced string with the following pieces:
+2 ; 1 - BMI value (not rounded)
+3 ; 2 - HT value used (not rounded)
+4 ; 3 - Date of HT value used in internal fileman format
+5 ; 4 - visit ien of visit on which HT found
+6 ; 5 - WT used (not rounded)
+7 ; 6 - date of weight used
+8 ; 7 - visit ien of visit on which weight found
+9 ;
+10 ;NOTE: any weight taken on a prenatal visit is excluded and a prior weight is used
+11 ;NOTE: if you add warnings, please use the word WARNING (caps) in the error message
+12 ;NOTE: pts <18 must have ht/wt on same day and within past year
+13 ; pts >50 must have ht/wt within past 2 years
+14 ; pts 19-50 must have ht/wt within past5 years
+15 ;
+16 NEW %,W,H,B,D,%DT,BDATE,AGE,WD,HD,VALUE,V,ERRC,ERR,BMI,CD,WD,HD,WV,HV,OW,OH
+17 SET ERRC=0
+18 SET VALUE=""
+19 IF $GET(EDATE)=""
SET EDATE=DT
+20 IF $GET(P)=""
QUIT "^^^^^^^PATIENT DFN INVALID"
+21 IF '$DATA(^AUPNPAT(P,0))
QUIT "^^^^^^^PATIENT DFN INVALID"
+22 IF '$DATA(^DPT(P,0))
QUIT "^^^^^^^PATIENT DFN INVALID"
+23 SET AGE=$$AGE^AUPNPAT(P,EDATE)
+24 SET VALUE=""
+25 IF AGE>18
IF AGE<50
Begin DoDot:1
+26 ;5 yrs
SET BDATE=$$FMADD^XLFDT(EDATE,-(5*365))
+27 SET EDATE=$$FMTE^XLFDT(EDATE)
+28 ;get last weight on file
+29 SET V=$$WT(P,BDATE,EDATE)
+30 SET (W,OW)=$PIECE(V,U,1)
+31 IF W=""!(W="?")
SET ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+32 SET WD=$PIECE(V,U,2)
+33 SET WV=$PIECE(V,U,3)
+34 SET V=$$HT(P,BDATE,EDATE)
+35 SET (H,OH)=$PIECE(V,U,1)
+36 IF H=""
SET ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+37 SET HD=$PIECE(V,U,2)
+38 SET HV=$PIECE(V,U,3)
+39 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+40 DO SETV
End DoDot:1
QUIT VALUE
+41 IF AGE>49
Begin DoDot:1
+42 ;2 yrs
SET BDATE=$$FMADD^XLFDT(EDATE,-(2*365))
+43 SET EDATE=$$FMTE^XLFDT(EDATE)
+44 ;get last weight on file
+45 SET V=$$WT(P,BDATE,EDATE)
+46 SET (W,OW)=$PIECE(V,U,1)
+47 IF W=""!(W="?")
SET ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+48 ;weight date
SET WD=$PIECE(V,U,2)
+49 SET WV=$PIECE(V,U,3)
+50 SET V=$$HT(P,BDATE,EDATE)
+51 SET (H,OH)=$PIECE(V,U,1)
+52 IF H=""
SET ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+53 SET HD=$PIECE(V,U,2)
+54 SET HV=$PIECE(V,U,3)
+55 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+56 DO SETV
+57 QUIT
End DoDot:1
QUIT VALUE
+58 IF AGE<19
Begin DoDot:1
+59 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+60 SET EDATE=$$FMTE^XLFDT(EDATE)
+61 SET X=$$HTWTSD(P,BDATE,EDATE)
+62 IF '$PIECE(X,"^")
SET ERR="NO WEIGHT FOUND ON SAME DAY AS HT ON OR PRIOR TO "_EDATE
DO ERR
QUIT
+63 IF '$PIECE(X,"^",4)
SET ERR="NO HEIGHT FOUND ON SAME DAY AS WT ON OR PRIOR TO "_EDATE
DO ERR
QUIT
+64 SET (W,OW)=$PIECE(X,"^")
+65 SET (H,OH)=$PIECE(X,"^",4)
+66 SET WD=$PIECE(X,U,2)
+67 SET WV=$PIECE(X,U,3)
+68 SET HD=$PIECE(X,U,5)
+69 SET HV=$PIECE(X,U,6)
+70 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+71 DO SETV
+72 QUIT
End DoDot:1
QUIT VALUE
+73 QUIT
HTWTSD(P,BDATE,EDATE) ;EP - get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 NEW APCLWTS,APCLHTS,%,X,APCLWTS1,APCLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(APCLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(APCLHTS(Y),U,2)="?"!($PIECE(APCLHTS(Y),U,2)="")
KILL APCLHTS(Y)
+6 KILL APCLHTS1
SET X=0
FOR
SET X=$ORDER(APCLHTS(X))
IF X'=+X
QUIT
SET APCLHTS1($PIECE(APCLHTS(X),U))=X
+7 ;get all wts during time frame
+8 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLWTS(")
+9 SET Y=0
FOR
SET Y=$ORDER(APCLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(APCLWTS(Y),U,2)="?"!($PIECE(APCLWTS(Y),U,2)="")
KILL APCLWTS(Y)
+10 ;set the array up by date
+11 KILL APCLWTS1
SET X=0
FOR
SET X=$ORDER(APCLWTS(X))
IF X'=+X
QUIT
SET APCLWTS1($PIECE(APCLWTS(X),U))=X
+12 SET APCLCHT=""
SET X=9999999
FOR
SET X=$ORDER(APCLWTS1(X),-1)
IF X=""!(APCLCHT]"")
QUIT
IF $DATA(APCLHTS1(X))
Begin DoDot:1
+13 SET APCLCHT=$PIECE(APCLWTS(APCLWTS1(X)),U,2)_U_$PIECE(APCLWTS(APCLWTS1(X)),U,1)_U_$PIECE(APCLWTS(APCLWTS1(X)),U,5)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,2)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,1)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,5)
End DoDot:1
+14 QUIT APCLCHT
+15 ;
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,APCLARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLARRY(")
+4 SET H=$PIECE($GET(APCLARRY(1)),U,2)
+5 IF H=""
QUIT H
+6 IF H["?"
QUIT ""
+7 SET H=H_U_$PIECE(APCLARRY(1),U,1)_U_$PIECE(APCLARRY(1),U,5)
+8 QUIT H
+9 ;
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,APCLLW,X,APCLLN,APCLL,APCLLD,APCLLZ,APCLLX,APCLICD
+3 KILL APCLL
SET APCLLW=""
SET APCLLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(APCLLX,"APCLL(")
+4 SET APCLLN=0
FOR
SET APCLLN=$ORDER(APCLL(APCLLN))
IF APCLLN'=+APCLLN!(APCLLW]"")
QUIT
Begin DoDot:1
+5 SET APCLLZ=$PIECE(APCLL(APCLLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",APCLLZ))
SET APCLLW=$PIECE(APCLL(APCLLN),U,2)_U_$PIECE(APCLL(APCLLN),U,1)_U_$PIECE(APCLL(APCLLN),U,5)
QUIT
+7 SET APCLLD=0
FOR
SET APCLLD=$ORDER(^AUPNVPOV("AD",APCLLZ,APCLLD))
IF 'APCLLD!(APCLLW]"")
QUIT
Begin DoDot:2
+8 SET APCLICD=$PIECE($$ICDDX^APCLSILU($PIECE(^AUPNVPOV(APCLLD,0),U)),U,2)
Begin DoDot:3
+9 IF $$ICD^APCLSILU(APCLICD,$ORDER(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0)),9)
QUIT
+10 SET APCLLW=$PIECE(APCLL(APCLLN),U,2)_U_$PIECE(APCLL(APCLLN),U,1)_U_$PIECE(APCLL(APCLLN),U,5)
End DoDot:3
+11 QUIT
End DoDot:2
End DoDot:1
+12 QUIT APCLLW
+13 ;
ERR ;EP
+1 SET ERRC=ERRC+1
+2 NEW C
+3 SET C=$PIECE(VALUE,U,8)
+4 SET $PIECE(C,"|",ERRC)=ERR
+5 SET $PIECE(VALUE,U,8)=C
+6 QUIT
+7 ;
SETV ;EP
+1 SET $PIECE(VALUE,U,1)=BMI
+2 SET $PIECE(VALUE,U,2)=OH
+3 SET $PIECE(VALUE,U,3)=HD
+4 SET $PIECE(VALUE,U,4)=HV
+5 SET $PIECE(VALUE,U,5)=OW
+6 SET $PIECE(VALUE,U,6)=WD
+7 SET $PIECE(VALUE,U,7)=WV
+8 QUIT
+9 ;
ASTDM(P,EDATE) ;EP
+1 ;asthma active problem list
+2 NEW X,Y,Q,G,T,APCL,%,E,V,TD,APCLAS,APCLDM,APCLDMC,APCLASC
+3 SET APCLAS=""
SET APCLDM=""
SET APCLASC=0
SET APCLDMC=0
+4 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+5 SET TD=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+6 SET G=""
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNPROB(X,0))
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+12 SET Q=$PIECE(^AUPNPROB(X,0),U)
+13 IF $$ICD^APCLSILU(Q,T,9)
SET APCLAS="Y"
QUIT
+14 IF $$ICD^APCLSILU(Q,TD,9)
SET APCLDM="Y"
QUIT
End DoDot:1
+15 IF APCLAS]""
IF APCLDM]""
QUIT APCLAS_U_APCLDM
+16 ;now for 2 povs on 2 different days, primary dx only, aorsh only
+17 DO ALLV^APCLAPIU(P,,EDATE,"APCL")
+18 IF '$DATA(APCL)
QUIT APCLAS_U_APCLDM
+19 ;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma OR DM
+20 NEW APCLJ,APCLK
+21 SET X=0
FOR
SET X=$ORDER(APCL(X))
IF X'=+X!(APCLAS]""&(APCLDM]""))
QUIT
Begin DoDot:1
+22 SET V=$PIECE(APCL(X),U,5)
+23 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+24 IF "AORSH"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+25 SET Q=$$PRIMPOV^APCLV(V,"I")
+26 ;no primary dx
IF Q=""
QUIT
+27 ;not in taxonomy
IF $$ICD^APCLSILU(Q,T,9)
IF '$DATA(APCLJ($PIECE(APCL(X),U,1)))
SET APCLJ($PIECE(APCL(X),U,1))=""
SET APCLASC=APCLASC+1
IF APCLASC>1
SET APCLAS="Y"
+28 ;not in taxonomy
IF $$ICD^APCLSILU(Q,TD,9)
IF '$DATA(APCLK($PIECE(APCL(X),U,1)))
SET APCLK($PIECE(APCL(X),U,1))=""
SET APCLDMC=APCLDMC+1
IF APCLDMC>1
SET APCLDM="Y"
+29 QUIT
End DoDot:1
+30 QUIT APCLAS_U_APCLDM
REF(V) ;EP
+1 ;is there a referral with a referral date of the visit date or 1 day later
+2 NEW B,E,X,Y,Z,P,C
+3 SET C=""
+4 SET B=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+5 SET E=$$FMADD^XLFDT($SELECT($PIECE(^AUPNVSIT(V,0),U,7)="H":$$DSCHDATE(V),1:B),1)
+6 SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+7 SET X=0
FOR
SET X=$ORDER(^BMCREF("D",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET D=$PIECE($GET(^BMCREF(X,0)),U,1)
+9 IF D=""
QUIT
+10 IF D<B
QUIT
+11 IF D>E
QUIT
+12 IF $PIECE(^BMCREF(X,0),U,14)'="I"
+13 SET C="Y"_U_D
+14 QUIT
End DoDot:1
+15 QUIT C
+16 ;
DSCHTYPE(V) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),"^",7)'="H"
QUIT ""
+4 NEW %,Y,Z
+5 IF $PIECE(^AUPNVSIT(V,0),"^",3)="C"
GOTO CHSDT
+6 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+7 IF 'Z
QUIT Z
+8 SET Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
+9 IF 'Y
QUIT ""
+10 IF $PIECE(^DD(9000010.02,.06,0),"^",2)[42.2
QUIT $PIECE($GET(^DIC(42.2,Y,0)),"^")
+11 IF $PIECE(^DD(9000010.02,.06,0),"^",2)[405.1
QUIT $PIECE($GET(^DG(405.1,Y,0)),"^")
+12 QUIT ""
CHSDT ;
+1 SET Z=$ORDER(^AUPNVCHS("AD",V,0))
IF 'Z
QUIT ""
+2 SET Y=$$VAL^XBDIQ1(9000010.03,Z,.08)
+3 QUIT Y
DSCHDATE(V) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $PIECE(^AUPNVSIT(V,0),"^",7)'="H"
QUIT ""
+4 NEW Y,Z
+5 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
GOTO CHSDD
+6 SET Y=$PIECE(^AUPNVINP(Z,0),"^")
+7 IF Y=""
QUIT Y
+8 QUIT $PIECE(Y,".")
CHSDD ;
+1 SET Z=$ORDER(^AUPNVCHS("AD",V,0))
IF 'Z
QUIT Z
+2 SET Y=$PIECE(^AUPNVCHS(Z,0),"^",7)
+3 IF Y=""
QUIT Y
+4 QUIT $PIECE(Y,".")
+5 ;
DATE(D) ;
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
+2 ;
JDATE(D) ;EP
+1 IF $GET(D)=""
QUIT ""
+2 NEW A
+3 SET A=$$FMTE^XLFDT(D)
+4 QUIT $EXTRACT(D,6,7)_$$UP^XLFSTR($PIECE(A," ",1))_(1700+$EXTRACT(D,1,3))
+5 ;
UID(APCLA) ;Given DFN return unique patient record id.
+1 IF '$GET(APCLA)
QUIT ""
+2 IF '$DATA(^AUPNPAT(APCLA))
QUIT ""
+3 ;
+4 QUIT $$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(APCLA))_APCLA
+5 ;
