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

APCLV2.m

Go to the documentation of this file. 
  1. APCLV2 ; IHS/CMI/LAB - get values for stat record ;
  1.  ;;2.0;IHS PCC SUITE;**2,4,10,11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;IHS/TUCSON/LAB - patch 1 - 06/02/97 - added this new routine to 
  1.  ;support additions to the statistical database record
  1.  ;;CMI/LAB - Patch 2 -02/23/98 - modified subroutines ACE and DMNUTR
  1.  ;;to fix problems with the data being passed to the data center
  1.  ;cmi/anch/maw 9/12/2007 code set versioning in WT
  1.  ;
  1. HGBA1C(V) ;EP - called to return value of HGBA1C if done on this visit
  1.  ;V is visit ien
  1.  NEW R
  1.  S R=""
  1.  I '$D(^AUPNVSIT(V)) Q R
  1.  I '$D(^AUPNVLAB("AD",V)) Q R  ;no v labs to check
  1.  I '$D(^ATXLAB("B","DM AUDIT HGB A1C TAX")) Q R
  1.  NEW Y S Y=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
  1.  I 'Y Q R  ;no taxonomy to look at
  1.  NEW X,Z
  1.  S X=0 F  S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X  S Z=$P(^AUPNVLAB(X,0),U) I Z,$D(^ATXLAB(Y,21,"B",Z)) S R=$P(^AUPNVLAB(X,0),U,4)
  1.  Q R
  1.  ;
  1. HTN(P) ;EP - is htn documented for this patient ever?  Y or N retured
  1.  NEW R,X,E,APCLV2
  1.  S R=""
  1.  I '$D(^DPT(P)) Q R
  1.  I $P(^DPT(P,0),U,19) Q R
  1.  I '$D(^AUPNVPOV("AC",P)) Q R  ;no povs on file
  1.  NEW X,E S X=P_"^LAST DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"APCLV2(")
  1.  Q $P($G(APCLV2(1)),U)
  1.  ;
  1. BP(V) ;EP - systolic pressure this visit
  1.  ;V is visit ien
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I '$D(^AUPNVMSR("AD",V)) Q ""
  1.  NEW Y S Y=$O(^AUTTMSR("B","BP",0))
  1.  I 'Y Q ""
  1.  NEW X,Z,R S R=""
  1.  S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  I $P(^AUPNVMSR(X,0),U)=Y,'$P($G(^AUPNVMSR(X,2)),U,1) S R=$P(^AUPNVMSR(X,0),U,4)
  1.  Q R
  1.  ;
  1. ACE(V) ;EP - ace inhibitor filled this visit
  1.  ;V is visit ien
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I '$D(^AUPNVMED("AD",V)) Q "N"  ;no v meds to check
  1.  NEW Y S Y=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
  1.  I 'Y Q ""
  1.  ;CMI/LAB 02/23/98 Patch #2 Modified subroutine to fix problems with
  1.  ;data being passed to the Data Center.
  1.  ;Added R to NEW statement below and added the setting of R=""
  1.  ;in the line that follows
  1.  ;BEG ORG CODE
  1.  ;NEW X,Z
  1.  ;END ORG CODE
  1.  ;BEG NEW CODE
  1.  NEW X,Z,R
  1.  S R=""
  1.  ;END NEW CODE
  1.  S X=0 F  S X=$O(^AUPNVMED("AD",V,X)) Q:X'=+X  S Z=$P(^AUPNVMED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1
  1.  Q $S($G(R):"Y",1:"N")
  1.  ;
  1. RW(V) ;EP called to return %recommended weight
  1.  I '$G(V) Q ""
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I '$D(^AUPNVMSR("AD",V)) Q ""
  1.  NEW Y S Y=$O(^AUTTMSR("B","WT",0))
  1.  I 'Y Q ""
  1.  NEW X,Z,R S R=""
  1.  S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  I $P(^AUPNVMSR(X,0),U)=Y S R=$P(^AUPNVMSR(X,0),U,4)
  1.  S R=$$RW^APCL2A3($P(^AUPNVSIT(V,0),U,5),R,$P(^AUPNVSIT(V,0),U))
  1.  Q R
  1.  ;
  1. DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N
  1.  I '$G(V) Q "N"
  1.  I '$D(^AUPNVSIT(V)) Q "N"
  1.  I '$D(^AUPNVPED("AD",V)) Q "N"
  1.  NEW Y S Y=$O(^ATXAX("B","APCL DM NUTRITION EDUC TOPICS",0))
  1.  I 'Y Q ""
  1.  ;CMI/LAB 02/23/98 Patch #2 - Modified subroutine to fix problems with 
  1.  ;data being passed to the Data Center
  1.  ;Added R to NEW statement below and added the setting of R=""
  1.  ;in the line that follows.
  1.  ;BEG ORG CODE
  1.  ;NEW X,Z
  1.  ;END ORG CODE
  1.  ;BEG NEW CODE
  1.  NEW X,Z,R
  1.  S R=""
  1.  ;END NEW CODE
  1.  S X=0 F  S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X  S Z=$P(^AUPNVPED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1
  1.  Q $S($G(R):"Y",1:"N")
  1.  ;
  1. HC(V) ;EP - return y or n if head circumference done
  1.  ;V is visit ien
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I '$D(^AUPNVMSR("AD",V)) Q "N"
  1.  NEW Y S Y=$O(^AUTTMSR("B","HC",0))
  1.  I 'Y Q ""
  1.  NEW X,Z,R S R=""
  1.  S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  I $P(^AUPNVMSR(X,0),U)=Y S R=1
  1.  Q $S($G(R):"Y",1:"N")
  1.  ;
  1.  ;
  1. DISPER(V) ;EP - called to get ER disposition
  1.  I '$G(V) Q ""
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I $$CLINIC^APCLV(V,"C")'=30 Q ""
  1.  NEW Y S Y=$O(^AUPNVER("AD",V,0)) I 'Y Q ""
  1.  Q $$VALI^XBDIQ1(9000010.29,Y,.11)
  1.  ;
  1. PBMI ;EP
  1.  NEW %,W,H,B,D,%DT,BDATE,AGE,WD,HD,VALUE,V,ERRC,ERR,BMI,CD,WD,HD,WV,HV,OW,OH,LBMI
  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.  ;GET LAST STORED BMI IF DOESN'T EXIT THEN MOVE ON TO CALCULATE IT
  1.  ;S LBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",,EDATE,"A")
  1.  ;I LBMI]""  D  Q VALUE
  1.  ;.S W=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",,EDATE,"A")
  1.  ;.S H=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",,EDATE,"A")
  1.  ;.S VALUE=$P(LBMI,U,3)_U_$P(H,U,3)_U_$P(H,U,1)_U_$P(H,U,4)_U_$P(W,U,3)_U_$P(W,U,1)_U_$P(W,U,4)_U_U_$P(LBMI,U,1)_U_$P(LBMI,U,6)
  1.  S AGE=$$AGE^AUPNPAT(P,EDATE)
  1.  S VALUE=""
  1.  I AGE>18,AGE<50 D  Q VALUE
  1.  .S CD=$$FMADD^XLFDT(EDATE,-(5*365))  ;5 yrs
  1.  .S BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
  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)  ;weight value
  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.  .I WD<CD S ERR="WARNING: WEIGHT IS GREATER THAN 5 YRS OLD" D ERR
  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.  .I HD<CD S ERR="WARNING: HEIGHT IS GREATER THAN 5 YRS OLD" D ERR
  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 CD=$$FMADD^XLFDT(EDATE,-(2*365))  ;5 yrs
  1.  .S BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
  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)  ;weight value
  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.  .I WD<CD S ERR="WARNING: WEIGHT IS GREATER THAN 2 YRS OLD" D ERR
  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.  .I HD<CD S ERR="WARNING: HEIGHT IS GREATER THAN 2 YRS OLD" D ERR
  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 CD=$$FMADD^XLFDT(EDATE,-365)
  1.  .S BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
  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,"^"),(H,OH)=$P(X,"^",4)
  1.  .S WD=$P(X,U,2)
  1.  .I WD<CD S ERR="WARNING: WEIGHT IS OVER 1 YEAR OLD" D ERR
  1.  .S WV=$P(X,U,3)
  1.  .S HD=$P(X,U,5)
  1.  .I HD<CD S ERR="WARNING: HEIGHT IS OVER 1 YEAR OLD" D ERR
  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) ;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.  ;set the array up by date
  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,G=0 F  S APCLLD=$O(^AUPNVPOV("AD",APCLLZ,APCLLD)) Q:'APCLLD!(G)  D
  1.  .. S APCLICD=$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLLD,0),U)),U,2) D  ;cmi/anch/maw 9/12/2007 csv
  1.  ...I $$ICD^ATXAPI(APCLICD,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) S G=1
  1.  ..I 'G 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 ;
  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 ;
  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