Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLSIL2

APCLSIL2.m

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