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

BUDHUTL2.m

Go to the documentation of this file. 
  1. BUDHUTL2 ; IHS/CMI/LAB - utilities for BUD ;
  1.  ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
  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. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1.  ;
  1. FITDNA(P,BDATE,EDATE) ;EP
  1.  I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-3_$E(EDATE,4,7)
  1.  S BUDD="",BUDLFOB=""
  1.  S T=$O(^ATXAX("B","BGP FIT-DNA LOINC CODES",0))
  1.  S BUDLT=$O(^ATXLAB("B","BGP FIT-DNA TESTS",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BUDD]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDD]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDD]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDD="FIT-DNA: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDHDU(9999999-D)_U_(9999999-D) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BUDD="FIT-DNA: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDHDU(9999999-D)_U_(9999999-D) Q
  1.  ...Q
  1.  S BUDLFOB=BUDD
  1.  Q BUDLFOB
  1. CTC(P,BDATE,EDATE) ;EP
  1.  NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
  1.  I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-5_$E(EDATE,4,7)
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1.  S BUDTOB=""
  1.  S TIEN=$O(^BUDHTSSC("B","T6B CRC CT COLON CODES",0))
  1.  S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB]"")  D
  1.  .S VIEN=$P(BUDVS(CTR),U,5)
  1.  .S VDATE=$P(BUDVS(CTR),U,1)
  1.  .;POV/SNOMED
  1.  .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"")  D
  1.  ..Q:'$D(^AUPNVPOV(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDTOB="CTC: DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
  1.  ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDTOB="CTC: DX "_Y_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
  1.  .;CPT
  1.  .S X=0 F  S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"")  D
  1.  ..Q:'$D(^AUPNVCPT(X,0))
  1.  ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDTOB="CTC: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
  1.  .;V TRANS
  1.  .S X=0 F  S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"")  D
  1.  ..Q:'$D(^AUPNVTC(X,0))
  1.  ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDTOB="CTC: CPT "_Y_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
  1.  .;V PROC
  1.  .S X=0 F  S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"")  D
  1.  ..Q:'$D(^AUPNVPRC(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
  1.  ..I $D(^BUDHTSSC("AP",Y,TIEN)) S BUDTOB="CTC: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
  1.  I BUDTOB]"" Q BUDTOB
  1.  Q ""
  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,TAXRN) ;EP
  1.  S TAXM=$G(TAXM)
  1.  S TAXN=$G(TAXN)
  1.  S TAXC=$G(TAXC)
  1.  S TAXRXN=$G(TAXRXN)
  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 T3="" I TAXRXN]"" S T3=$O(^ATXAX("B",TAXRXN,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.  .S C=$$VAL^XBDIQ1(9000010.14,Y,9999999.27)
  1.  .I C]"",T3,$D(^ATXAX(T3,21,"B",C)) 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
  1. HL(P,BD,ED) ;EP - was patient homeless on any day in this time period?
  1.  I '$O(^AUPNPAT(P,85,0)) Q ""
  1.  ;SET UP ARRAY OF DATES OF HOMELESSNESS
  1.  NEW X,Y,Z,N,B,C,A
  1.  S X=0 F  S X=$O(^AUPNPAT(P,85,"B",X)) Q:X'=+X  D
  1.  .S Y=0 F  S Y=$O(^AUPNPAT(P,85,"B",X,Y)) Q:Y'=+Y  D
  1.  ..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="" Q
  1.  ..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="N" Q
  1.  ..;okay is homeless until the next value of "N" or DT if none found
  1.  ..S N=X,A="" F  S N=$O(^AUPNPAT(P,85,"B",N)) Q:N'=+N!(A)  D
  1.  ...S B=0 F  S B=$O(^AUPNPAT(P,85,"B",N,B)) Q:B'=+B!(A)  D
  1.  ....I $P($G(^AUPNPAT(P,85,B,0)),U,2)="" Q
  1.  ....I $P($G(^AUPNPAT(P,85,B,0)),U,2)="Y" Q
  1.  ....S A=N  ;so is homeless from X TO A
  1.  ..I 'A S A=DT
  1.  ..S Z(X)=X_U_$$FMADD^XLFDT(A,-1)
  1.  S X=0 ;CHECK EACH ONE TO SEE IF ANY ENCOMPASS BD TO ED
  1.  S Y=0 F  S Y=$O(Z(Y)) Q:Y'=+Y  D
  1.  .S B=$P(Z(Y),U,1)
  1.  .S E=$P(Z(Y),U,2)
  1.  .Q:B>ED  ;begins after end date of report period
  1.  .Q:E<BD  ;ends before report period
  1.  .S X=1
  1.  Q X
  1. ALLCPT(P,BD,ED,T,A) ;EP - ALL CPTS IN A DATE RANGE IN TAXONOMY T
  1.  ;P - patient
  1.  ;BD - beginning date
  1.  ;ED - ending date
  1.  ;T -  taxonomy IEN
  1.  ;return all CPTSthat match in array A
  1.  ;FORMAT:  1^DATE^CPT CODE EXTERNAL^V CPT IEN^VISIT IEN
  1.  S T=$G(T)
  1.  I 'T Q
  1.  NEW D,V,G,X,J,B,E,BUDC,CPTTAX
  1.  ;UNFOLD TAXONOMY
  1.  D BLDTAX^ATXAPI($P(^ATXAX(T,0),U,1),"CPTTAX",T,"")
  1.  S BUDC=0
  1.  S J=0 F  S J=$O(CPTTAX(J)) Q:J=""  D
  1.  .S B=9999999-BD,E=9999999-ED  ;get inverse date and begin at edate-1 and end when greater than begin date
  1.  .S D=E-1,D=D_".9999" S G=0 F  S D=$O(^AUPNVCPT("AA",P,J,D)) Q:D'=+D!($P(D,".")>B)  D
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AA",P,J,D,X)) Q:X'=+X  D
  1.  ...S BUDC=BUDC+1
  1.  ...S @A@(BUDC)=(9999999-$P(D,"."))_"^"_$P(CPTTAX(J),U,1)_"^"_X_"^"_$P($G(^AUPNVCPT(X,0)),U,3)
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  Q
  1. SETUP ;EP - set up table 6 and 7 dx and snomed lists in ^BUDHTSSC
  1.  NEW BUDX,BUDS,OUT,N,BUDI,C,I,BUDTAX,BUDTGT
  1.  I $T(SUBLST^BSTSAPI)="" G DX  ;NO SNOMED STUFF INSTALLED
  1.  ;
  1.  S BUDX=0 F  S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX  D
  1.  .Q:$P(^BUDHTSSC(BUDX,0),U,2)=""  ;no snomed subset
  1.  .;delete all old snomed entries for this entry
  1.  .S BUDI=0 F  S BUDI=$O(^BUDHTSSC(BUDX,13,BUDI)) Q:BUDI'=+BUDI  D
  1.  ..K DIC,DR,DA S DA(1)=BUDX,DA=BUDI,DIE="^BUDHTSSC("_BUDX_",13,",DR=".01///@" D ^DIE K DIE,DA,DR
  1.  .K ^TMP($J,"SUB")
  1.  .S OUT=$NA(^TMP($J,"SUB"))
  1.  .S N=$P(^BUDHTSSC(BUDX,0),U,2)
  1.  .S X=$$SUBLST^BSTSAPI(OUT,N)  ;
  1.  .;BUILD INDEX
  1.  .S C=0 F  S C=$O(^TMP($J,"SUB",C)) Q:C'=+C  S I=$P(^TMP($J,"SUB",C),U,1) I I]"" S ^BUDHTSSC(BUDX,13,C,0)=I
  1.  .K DIK,DA S DA=BUDX,DIK="^BUDHTSSC(" D IX1^DIK K DIK,DA
  1. DX ;
  1.  S BUDX=0 F  S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX  D
  1.  .Q:$P(^BUDHTSSC(BUDX,0),U,3)=""  ;no DX TAXONOMY
  1.  .;delete all old ICD entries for this entry
  1.  .S BUDI=0 F  S BUDI=$O(^BUDHTSSC(BUDX,11,BUDI)) Q:BUDI'=+BUDI  D
  1.  ..K DIC,DR,DA S DA(1)=BUDX,DA=BUDI,DIE="^BUDHTSSC("_BUDX_",11,",DR=".01///@" D ^DIE K DIE,DA,DR
  1.  .S BUDTGT="BUDTAX"
  1.  .D BLDTAX^ATXAPI($P(^BUDHTSSC(BUDX,0),U,3),BUDTGT,$O(^ATXAX("B",$P(^BUDHTSSC(BUDX,0),U,3),0)))
  1.  .;BUILD INDEX
  1.  .S C=0,X=0 F  S X=$O(BUDTAX(X)) Q:X'=+X  D
  1.  ..S C=C+1
  1.  ..S ^BUDHTSSC(BUDX,11,C,0)=$P(BUDTAX(X),U,1)_U_X_U_$P(BUDTAX(X),U,3)
  1.  .S ^BUDHTSSC(BUDX,1,0)="^90669.90811^"_C_"^"_C
  1.  .K DIK,DA S DA=BUDX,DIK="^BUDHTSSC(" D IX1^DIK K DIK,DA
  1.  Q