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

BUDDUTL2.m

Go to the documentation of this file. 
  1. BUDDUTL2 ; IHS/CMI/LAB - utilities for BUD ;
  1.  ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
  1.  ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
  1.  ;;  RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
  1.  ;;  PATCH 1: Correct test for Active Chart at site DUZ2.  INACTREG+11
  1.  ;;           Also, add Street Address Line 2 aAPCLlity.  STREET+0
  1.  ;;           Also, provide test for patient IneligiAPCLlity  INELIG+0
  1.  ;
  1.  ;----------
  1. DOB(DFN) ;EP
  1.  ;---> Return Patient's Date of APCLrth in Fileman format.
  1.  ;---> Parameters:
  1.  ;     1 - DFN   (req) Patient's IEN (DFN).
  1.  ;
  1.  Q:'$G(DFN) "NO PATIENT"
  1.  Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
  1.  Q $P(^DPT(DFN,0),U,3)
  1.  ;
  1.  ;
  1.  ;
  1.  ;----------
  1. AGE(DFN,APCLZ,APCLDT) ;EP
  1.  ;---> Return Patient's Age.
  1.  ;---> Parameters:
  1.  ;     1 - DFN  (req) IEN in PATIENT File.
  1.  ;     2 - APCLZ  (opt) APCLZ=1,2,3  1=years, 2=months, 3=days.
  1.  ;                               2 will be assumed if not passed.
  1.  ;     3 - APCLDT (opt) Date on which Age should be calculated.
  1.  ;
  1.  N APCLDOB,X,X1,X2  S:$G(APCLZ)="" APCLZ=2
  1.  Q:'$G(DFN) ""
  1.  S APCLDOB=$$DOB(DFN)
  1.  Q:'APCLDOB ""
  1.  S:'$G(DT) DT=$$DT^XLFDT
  1.  S:'$G(APCLDT) APCLDT=DT
  1.  Q:APCLDT<APCLDOB ""
  1.  ;
  1.  ;---> Age in Years.
  1.  N APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
  1.  S APCLM1=$E(APCLDOB,4,7),APCLM2=$E(APCLDT,4,7)
  1.  S APCLY1=$E(APCLDOB,1,3),APCLY2=$E(APCLDT,1,3)
  1.  S APCLAGEY=APCLY2-APCLY1 S:APCLM2<APCLM1 APCLAGEY=APCLAGEY-1
  1.  S:APCLAGEY<1 APCLAGEY="<1"
  1.  Q:APCLZ=1 APCLAGEY
  1.  ;
  1.  ;---> Age in Months.
  1.  S APCLD1=$E(APCLM1,3,4),APCLM1=$E(APCLM1,1,2)
  1.  S APCLD2=$E(APCLM2,3,4),APCLM2=$E(APCLM2,1,2)
  1.  S APCLAGEM=12*APCLAGEY
  1.  I APCLM2=APCLM1&(APCLD2<APCLD1) S APCLAGEM=APCLAGEM+12
  1.  I APCLM2>APCLM1 S APCLAGEM=APCLAGEM+APCLM2-APCLM1
  1.  I APCLM2<APCLM1 S APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
  1.  S:APCLD2<APCLD1 APCLAGEM=APCLAGEM-1
  1.  Q:APCLZ=2 APCLAGEM
  1.  ;
  1.  ;---> Age in Days.
  1.  S X1=APCLDT,X2=APCLDOB
  1.  D ^%DTC
  1.  Q X
  1.  ;
  1.  ;
  1.  ;----------
  1. AGEF(DFN,APCLDT) ;EP
  1.  ;---> Age formatted "35 Months" or "23 Years"
  1.  ;---> Parameters:
  1.  ;     1 - DFN  (req) Patient's IEN (DFN).
  1.  ;     2 - APCLDT (opt) Date on which Age should be calculated.
  1.  ;
  1.  N Y
  1.  S Y=$$AGE(DFN,2,$G(APCLDT))
  1.  Q:Y["DECEASED" Y
  1.  Q:Y["NOT BORN" Y
  1.  ;
  1.  ;---> If over 60 months, return years.
  1.  I Y>60 S Y=$$AGE(DFN,1,$G(APCLDT)) Q Y_$S(Y=1:"year",1:" yrs")
  1.  ;
  1.  ;---> If under 1 month return days.
  1.  I Y<1 S Y=$$AGE(DFN,3,$G(APCLDT)) Q Y_$S(Y=1:" day",1:" days")
  1.  ;
  1.  ;---> Return months
  1.  Q Y_$S(Y=1:" mth",1:" mths")
  1.  ;
  1.  ;
  1.  ;----------
  1. DECEASED(DFN,APCLDT) ;EP
  1.  ;---> Return 1 if patient is deceased, 0 if not deceased.
  1.  ;---> Parameters:
  1.  ;     1 - DFN  (req) Patient's IEN (DFN).
  1.  ;     2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
  1.  ;
  1.  Q:'$G(DFN) 0
  1.  N X S X=+$G(^DPT(DFN,.35))
  1.  Q:'X 0
  1.  Q:'$G(APCLDT) 1
  1.  Q X
  1.  ;
  1.  ;
  1. GETMEDS(P,BUDMBD,BUDMED,TAXM,TAXN,TAXC,BUDDNAME,BUDZ) ;EP
  1.  S TAXM=$G(TAXM)
  1.  S TAXN=$G(TAXN)
  1.  S TAXC=$G(TAXC)
  1.  K ^TMP($J,"MEDS"),BUDZ
  1.  S BUDDNAME=$G(BUDDNAME)
  1.  NEW BUDCC1,BUDINED,BUDINBD,BUDMIEN,BUDD,X,Y,T,T1,D,G
  1.  S BUDCC1=0 K BUDZ
  1.  S BUDINED=(9999999-BUDMED)-1,BUDINBD=(9999999-BUDMBD)
  1.  F  S BUDINED=$O(^AUPNVMED("AA",P,BUDINED)) Q:BUDINED=""!(BUDINED>BUDINBD)  D
  1.  .S BUDMIEN=0 F  S BUDMIEN=$O(^AUPNVMED("AA",P,BUDINED,BUDMIEN)) Q:BUDMIEN'=+BUDMIEN  D
  1.  ..Q:'$D(^AUPNVMED(BUDMIEN,0))
  1.  ..S BUDD=$P(^AUPNVMED(BUDMIEN,0),U)
  1.  ..Q:BUDD=""
  1.  ..Q:'$D(^PSDRUG(BUDD,0))
  1.  ..S BUDCC1=BUDCC1+1
  1.  ..S ^TMP($J,"MEDS","ORDER",(9999999-BUDINED),BUDCC1)=(9999999-BUDINED)_U_$P(^PSDRUG(BUDD,0),U)_U_$P(^PSDRUG(BUDD,0),U)_U_BUDMIEN_U_$P(^AUPNVMED(BUDMIEN,0),U,3)
  1.  ;reorder
  1.  S BUDCC1=0,X=0
  1.  F  S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X  D
  1.  .S Y=0 F  S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y  D
  1.  ..S BUDCC1=BUDCC1+1
  1.  ..S ^TMP($J,"MEDS",BUDCC1)=^TMP($J,"MEDS","ORDER",X,Y)
  1.  K ^TMP($J,"MEDS","ORDER")
  1.  S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0))
  1.  S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0))
  1.  S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
  1.  S BUDCC1=0,X=0 F  S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X  S Y=+$P(^TMP($J,"MEDS",X),U,4) D
  1.  .Q:'$D(^AUPNVMED(Y,0))
  1.  .S G=0
  1.  .S D=$P(^AUPNVMED(Y,0),U)
  1.  .S C=$P($G(^PSDRUG(D,0)),U,2)
  1.  .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
  1.  .S C=$P($G(^PSDRUG(D,2)),U,4)
  1.  .I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
  1.  .I C]"",T1,$D(^ATXAX(T1,21,"B",$$STRIP^XLFSTR(C,"-"))) S G=1
  1.  .I T,$D(^ATXAX(T,21,"B",D)) S G=1
  1.  .I BUDDNAME]"",$P(^PSDRUG(D,0),U)[BUDDNAME S G=1
  1.  .I TAXM="",TAXN="",TAXC="" S G=1  ;WANTS ALL MEDS
  1.  .I G=1 S BUDCC1=BUDCC1+1,BUDZ(BUDCC1)=^TMP($J,"MEDS",X)
  1.  .Q
  1.  K ^TMP($J,"MEDS")
  1.  K BUDINED,BUDINBD,BUDMBD,BUDMED,BUDD,BUDCC1,BUDDNAME
  1.  Q