- BUDHUTL2 ; IHS/CMI/LAB - utilities for BUD ;
- ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
- ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
- ;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
- ;; PATCH 1: Correct test for Active Chart at site DUZ2. INACTREG+11
- ;; Also, add Street Address Line 2 aAPCLlity. STREET+0
- ;; Also, provide test for patient IneligiAPCLlity INELIG+0
- ;
- ;----------
- DOB(DFN) ;EP
- ;---> Return Patient's Date of APCLrth in Fileman format.
- ;---> Parameters:
- ; 1 - DFN (req) Patient's IEN (DFN).
- ;
- Q:'$G(DFN) "NO PATIENT"
- Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
- Q $P(^DPT(DFN,0),U,3)
- ;
- ;
- ;
- ;----------
- AGE(DFN,APCLZ,APCLDT) ;EP
- ;---> Return Patient's Age.
- ;---> Parameters:
- ; 1 - DFN (req) IEN in PATIENT File.
- ; 2 - APCLZ (opt) APCLZ=1,2,3 1=years, 2=months, 3=days.
- ; 2 will be assumed if not passed.
- ; 3 - APCLDT (opt) Date on which Age should be calculated.
- ;
- N APCLDOB,X,X1,X2 S:$G(APCLZ)="" APCLZ=2
- Q:'$G(DFN) ""
- S APCLDOB=$$DOB(DFN)
- Q:'APCLDOB ""
- S:'$G(DT) DT=$$DT^XLFDT
- S:'$G(APCLDT) APCLDT=DT
- Q:APCLDT<APCLDOB ""
- ;
- ;---> Age in Years.
- N APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
- S APCLM1=$E(APCLDOB,4,7),APCLM2=$E(APCLDT,4,7)
- S APCLY1=$E(APCLDOB,1,3),APCLY2=$E(APCLDT,1,3)
- S APCLAGEY=APCLY2-APCLY1 S:APCLM2<APCLM1 APCLAGEY=APCLAGEY-1
- S:APCLAGEY<1 APCLAGEY="<1"
- Q:APCLZ=1 APCLAGEY
- ;
- ;---> Age in Months.
- S APCLD1=$E(APCLM1,3,4),APCLM1=$E(APCLM1,1,2)
- S APCLD2=$E(APCLM2,3,4),APCLM2=$E(APCLM2,1,2)
- S APCLAGEM=12*APCLAGEY
- I APCLM2=APCLM1&(APCLD2<APCLD1) S APCLAGEM=APCLAGEM+12
- I APCLM2>APCLM1 S APCLAGEM=APCLAGEM+APCLM2-APCLM1
- I APCLM2<APCLM1 S APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
- S:APCLD2<APCLD1 APCLAGEM=APCLAGEM-1
- Q:APCLZ=2 APCLAGEM
- ;
- ;---> Age in Days.
- S X1=APCLDT,X2=APCLDOB
- D ^%DTC
- Q X
- ;
- ;
- ;
- LOINC(A,B) ;
- NEW %
- S %=$P($G(^LAB(95.3,A,9999999)),U,2)
- I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
- S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
- I $D(^ATXAX(B,21,"B",%)) Q 1
- Q ""
- ;
- FITDNA(P,BDATE,EDATE) ;EP
- I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-3_$E(EDATE,4,7)
- S BUDD="",BUDLFOB=""
- S T=$O(^ATXAX("B","BGP FIT-DNA LOINC CODES",0))
- S BUDLT=$O(^ATXLAB("B","BGP FIT-DNA TESTS",0))
- 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
- .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDD]"") D
- ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDD]"") D
- ...Q:'$D(^AUPNVLAB(X,0))
- ...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
- ...Q:'T
- ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
- ...Q:'$$LOINC(J,T)
- ...S BUDD="FIT-DNA: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDHDU(9999999-D)_U_(9999999-D) Q
- ...Q
- S BUDLFOB=BUDD
- Q BUDLFOB
- CTC(P,BDATE,EDATE) ;EP
- NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
- I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-5_$E(EDATE,4,7)
- D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
- S BUDTOB=""
- S TIEN=$O(^BUDHTSSC("B","T6B CRC CT COLON CODES",0))
- S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB]"") D
- .S VIEN=$P(BUDVS(CTR),U,5)
- .S VDATE=$P(BUDVS(CTR),U,1)
- .;POV/SNOMED
- .S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
- ..Q:'$D(^AUPNVPOV(X,0))
- ..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
- ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
- ..Q:Y=""
- ..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDTOB="CTC: DX "_Y_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
- .;CPT
- .S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
- ..Q:'$D(^AUPNVCPT(X,0))
- ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
- ..Q:Y=""
- ..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDTOB="CTC: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
- .;V TRANS
- .S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
- ..Q:'$D(^AUPNVTC(X,0))
- ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
- ..Q:Y=""
- ..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDTOB="CTC: CPT "_Y_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
- .;V PROC
- .S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
- ..Q:'$D(^AUPNVPRC(X,0))
- ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
- ..I $D(^BUDHTSSC("AP",Y,TIEN)) S BUDTOB="CTC: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDHDU(VDATE)_U_VDATE Q
- I BUDTOB]"" Q BUDTOB
- Q ""
- ;----------
- AGEF(DFN,APCLDT) ;EP
- ;---> Age formatted "35 Months" or "23 Years"
- ;---> Parameters:
- ; 1 - DFN (req) Patient's IEN (DFN).
- ; 2 - APCLDT (opt) Date on which Age should be calculated.
- ;
- N Y
- S Y=$$AGE(DFN,2,$G(APCLDT))
- Q:Y["DECEASED" Y
- Q:Y["NOT BORN" Y
- ;
- ;---> If over 60 months, return years.
- I Y>60 S Y=$$AGE(DFN,1,$G(APCLDT)) Q Y_$S(Y=1:"year",1:" yrs")
- ;
- ;---> If under 1 month return days.
- I Y<1 S Y=$$AGE(DFN,3,$G(APCLDT)) Q Y_$S(Y=1:" day",1:" days")
- ;
- ;---> Return months
- Q Y_$S(Y=1:" mth",1:" mths")
- ;
- ;
- ;----------
- DECEASED(DFN,APCLDT) ;EP
- ;---> Return 1 if patient is deceased, 0 if not deceased.
- ;---> Parameters:
- ; 1 - DFN (req) Patient's IEN (DFN).
- ; 2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
- ;
- Q:'$G(DFN) 0
- N X S X=+$G(^DPT(DFN,.35))
- Q:'X 0
- Q:'$G(APCLDT) 1
- Q X
- ;
- ;
- GETMEDS(P,BUDMBD,BUDMED,TAXM,TAXN,TAXC,BUDDNAME,BUDZ,TAXRN) ;EP
- S TAXM=$G(TAXM)
- S TAXN=$G(TAXN)
- S TAXC=$G(TAXC)
- S TAXRXN=$G(TAXRXN)
- K ^TMP($J,"MEDS"),BUDZ
- S BUDDNAME=$G(BUDDNAME)
- NEW BUDCC1,BUDINED,BUDINBD,BUDMIEN,BUDD,X,Y,T,T1,D,G
- S BUDCC1=0 K BUDZ
- S BUDINED=(9999999-BUDMED)-1,BUDINBD=(9999999-BUDMBD)
- F S BUDINED=$O(^AUPNVMED("AA",P,BUDINED)) Q:BUDINED=""!(BUDINED>BUDINBD) D
- .S BUDMIEN=0 F S BUDMIEN=$O(^AUPNVMED("AA",P,BUDINED,BUDMIEN)) Q:BUDMIEN'=+BUDMIEN D
- ..Q:'$D(^AUPNVMED(BUDMIEN,0))
- ..S BUDD=$P(^AUPNVMED(BUDMIEN,0),U)
- ..Q:BUDD=""
- ..Q:'$D(^PSDRUG(BUDD,0))
- ..S BUDCC1=BUDCC1+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)
- ;reorder
- S BUDCC1=0,X=0
- F S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X D
- .S Y=0 F S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y D
- ..S BUDCC1=BUDCC1+1
- ..S ^TMP($J,"MEDS",BUDCC1)=^TMP($J,"MEDS","ORDER",X,Y)
- K ^TMP($J,"MEDS","ORDER")
- S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0))
- S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0))
- S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
- S T3="" I TAXRXN]"" S T3=$O(^ATXAX("B",TAXRXN,0))
- 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
- .Q:'$D(^AUPNVMED(Y,0))
- .S G=0
- .S D=$P(^AUPNVMED(Y,0),U)
- .S C=$P($G(^PSDRUG(D,0)),U,2)
- .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
- .S C=$P($G(^PSDRUG(D,2)),U,4)
- .I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
- .I C]"",T1,$D(^ATXAX(T1,21,"B",$$STRIP^XLFSTR(C,"-"))) S G=1
- .I T,$D(^ATXAX(T,21,"B",D)) S G=1
- .I BUDDNAME]"",$P(^PSDRUG(D,0),U)[BUDDNAME S G=1
- .S C=$$VAL^XBDIQ1(9000010.14,Y,9999999.27)
- .I C]"",T3,$D(^ATXAX(T3,21,"B",C)) S G=1
- .I TAXM="",TAXN="",TAXC="" S G=1 ;WANTS ALL MEDS
- .I G=1 S BUDCC1=BUDCC1+1,BUDZ(BUDCC1)=^TMP($J,"MEDS",X)
- .Q
- K ^TMP($J,"MEDS")
- K BUDINED,BUDINBD,BUDMBD,BUDMED,BUDD,BUDCC1,BUDDNAME
- Q
- HL(P,BD,ED) ;EP - was patient homeless on any day in this time period?
- I '$O(^AUPNPAT(P,85,0)) Q ""
- ;SET UP ARRAY OF DATES OF HOMELESSNESS
- NEW X,Y,Z,N,B,C,A
- S X=0 F S X=$O(^AUPNPAT(P,85,"B",X)) Q:X'=+X D
- .S Y=0 F S Y=$O(^AUPNPAT(P,85,"B",X,Y)) Q:Y'=+Y D
- ..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="" Q
- ..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="N" Q
- ..;okay is homeless until the next value of "N" or DT if none found
- ..S N=X,A="" F S N=$O(^AUPNPAT(P,85,"B",N)) Q:N'=+N!(A) D
- ...S B=0 F S B=$O(^AUPNPAT(P,85,"B",N,B)) Q:B'=+B!(A) D
- ....I $P($G(^AUPNPAT(P,85,B,0)),U,2)="" Q
- ....I $P($G(^AUPNPAT(P,85,B,0)),U,2)="Y" Q
- ....S A=N ;so is homeless from X TO A
- ..I 'A S A=DT
- ..S Z(X)=X_U_$$FMADD^XLFDT(A,-1)
- S X=0 ;CHECK EACH ONE TO SEE IF ANY ENCOMPASS BD TO ED
- S Y=0 F S Y=$O(Z(Y)) Q:Y'=+Y D
- .S B=$P(Z(Y),U,1)
- .S E=$P(Z(Y),U,2)
- .Q:B>ED ;begins after end date of report period
- .Q:E<BD ;ends before report period
- .S X=1
- Q X
- ALLCPT(P,BD,ED,T,A) ;EP - ALL CPTS IN A DATE RANGE IN TAXONOMY T
- ;P - patient
- ;BD - beginning date
- ;ED - ending date
- ;T - taxonomy IEN
- ;return all CPTSthat match in array A
- ;FORMAT: 1^DATE^CPT CODE EXTERNAL^V CPT IEN^VISIT IEN
- S T=$G(T)
- I 'T Q
- NEW D,V,G,X,J,B,E,BUDC,CPTTAX
- ;UNFOLD TAXONOMY
- D BLDTAX^ATXAPI($P(^ATXAX(T,0),U,1),"CPTTAX",T,"")
- S BUDC=0
- S J=0 F S J=$O(CPTTAX(J)) Q:J="" D
- .S B=9999999-BD,E=9999999-ED ;get inverse date and begin at edate-1 and end when greater than begin date
- .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
- ..S X=0 F S X=$O(^AUPNVCPT("AA",P,J,D,X)) Q:X'=+X D
- ...S BUDC=BUDC+1
- ...S @A@(BUDC)=(9999999-$P(D,"."))_"^"_$P(CPTTAX(J),U,1)_"^"_X_"^"_$P($G(^AUPNVCPT(X,0)),U,3)
- ...Q
- ..Q
- .Q
- Q
- SETUP ;EP - set up table 6 and 7 dx and snomed lists in ^BUDHTSSC
- NEW BUDX,BUDS,OUT,N,BUDI,C,I,BUDTAX,BUDTGT
- I $T(SUBLST^BSTSAPI)="" G DX ;NO SNOMED STUFF INSTALLED
- ;
- S BUDX=0 F S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX D
- .Q:$P(^BUDHTSSC(BUDX,0),U,2)="" ;no snomed subset
- .;delete all old snomed entries for this entry
- .S BUDI=0 F S BUDI=$O(^BUDHTSSC(BUDX,13,BUDI)) Q:BUDI'=+BUDI D
- ..K DIC,DR,DA S DA(1)=BUDX,DA=BUDI,DIE="^BUDHTSSC("_BUDX_",13,",DR=".01///@" D ^DIE K DIE,DA,DR
- .K ^TMP($J,"SUB")
- .S OUT=$NA(^TMP($J,"SUB"))
- .S N=$P(^BUDHTSSC(BUDX,0),U,2)
- .S X=$$SUBLST^BSTSAPI(OUT,N) ;
- .;BUILD INDEX
- .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
- .K DIK,DA S DA=BUDX,DIK="^BUDHTSSC(" D IX1^DIK K DIK,DA
- DX ;
- S BUDX=0 F S BUDX=$O(^BUDHTSSC(BUDX)) Q:BUDX'=+BUDX D
- .Q:$P(^BUDHTSSC(BUDX,0),U,3)="" ;no DX TAXONOMY
- .;delete all old ICD entries for this entry
- .S BUDI=0 F S BUDI=$O(^BUDHTSSC(BUDX,11,BUDI)) Q:BUDI'=+BUDI D
- ..K DIC,DR,DA S DA(1)=BUDX,DA=BUDI,DIE="^BUDHTSSC("_BUDX_",11,",DR=".01///@" D ^DIE K DIE,DA,DR
- .S BUDTGT="BUDTAX"
- .D BLDTAX^ATXAPI($P(^BUDHTSSC(BUDX,0),U,3),BUDTGT,$O(^ATXAX("B",$P(^BUDHTSSC(BUDX,0),U,3),0)))
- .;BUILD INDEX
- .S C=0,X=0 F S X=$O(BUDTAX(X)) Q:X'=+X D
- ..S C=C+1
- ..S ^BUDHTSSC(BUDX,11,C,0)=$P(BUDTAX(X),U,1)_U_X_U_$P(BUDTAX(X),U,3)
- .S ^BUDHTSSC(BUDX,1,0)="^90669.90811^"_C_"^"_C
- .K DIK,DA S DA=BUDX,DIK="^BUDHTSSC(" D IX1^DIK K DIK,DA
- Q
- BUDHUTL2 ; IHS/CMI/LAB - utilities for BUD ;
- +1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
- +2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
- +3 ;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
- +4 ;; PATCH 1: Correct test for Active Chart at site DUZ2. INACTREG+11
- +5 ;; Also, add Street Address Line 2 aAPCLlity. STREET+0
- +6 ;; Also, provide test for patient IneligiAPCLlity INELIG+0
- +7 ;
- +8 ;----------
- DOB(DFN) ;EP
- +1 ;---> Return Patient's Date of APCLrth in Fileman format.
- +2 ;---> Parameters:
- +3 ; 1 - DFN (req) Patient's IEN (DFN).
- +4 ;
- +5 IF '$GET(DFN)
- QUIT "NO PATIENT"
- +6 IF '$PIECE($GET(^DPT(DFN,0)),U,3)
- QUIT "NOT ENTERED"
- +7 QUIT $PIECE(^DPT(DFN,0),U,3)
- +8 ;
- +9 ;
- +10 ;
- +11 ;----------
- AGE(DFN,APCLZ,APCLDT) ;EP
- +1 ;---> Return Patient's Age.
- +2 ;---> Parameters:
- +3 ; 1 - DFN (req) IEN in PATIENT File.
- +4 ; 2 - APCLZ (opt) APCLZ=1,2,3 1=years, 2=months, 3=days.
- +5 ; 2 will be assumed if not passed.
- +6 ; 3 - APCLDT (opt) Date on which Age should be calculated.
- +7 ;
- +8 NEW APCLDOB,X,X1,X2
- IF $GET(APCLZ)=""
- SET APCLZ=2
- +9 IF '$GET(DFN)
- QUIT ""
- +10 SET APCLDOB=$$DOB(DFN)
- +11 IF 'APCLDOB
- QUIT ""
- +12 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +13 IF '$GET(APCLDT)
- SET APCLDT=DT
- +14 IF APCLDT<APCLDOB
- QUIT ""
- +15 ;
- +16 ;---> Age in Years.
- +17 NEW APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
- +18 SET APCLM1=$EXTRACT(APCLDOB,4,7)
- SET APCLM2=$EXTRACT(APCLDT,4,7)
- +19 SET APCLY1=$EXTRACT(APCLDOB,1,3)
- SET APCLY2=$EXTRACT(APCLDT,1,3)
- +20 SET APCLAGEY=APCLY2-APCLY1
- IF APCLM2<APCLM1
- SET APCLAGEY=APCLAGEY-1
- +21 IF APCLAGEY<1
- SET APCLAGEY="<1"
- +22 IF APCLZ=1
- QUIT APCLAGEY
- +23 ;
- +24 ;---> Age in Months.
- +25 SET APCLD1=$EXTRACT(APCLM1,3,4)
- SET APCLM1=$EXTRACT(APCLM1,1,2)
- +26 SET APCLD2=$EXTRACT(APCLM2,3,4)
- SET APCLM2=$EXTRACT(APCLM2,1,2)
- +27 SET APCLAGEM=12*APCLAGEY
- +28 IF APCLM2=APCLM1&(APCLD2<APCLD1)
- SET APCLAGEM=APCLAGEM+12
- +29 IF APCLM2>APCLM1
- SET APCLAGEM=APCLAGEM+APCLM2-APCLM1
- +30 IF APCLM2<APCLM1
- SET APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
- +31 IF APCLD2<APCLD1
- SET APCLAGEM=APCLAGEM-1
- +32 IF APCLZ=2
- QUIT APCLAGEM
- +33 ;
- +34 ;---> Age in Days.
- +35 SET X1=APCLDT
- SET X2=APCLDOB
- +36 DO ^%DTC
- +37 QUIT X
- +38 ;
- +39 ;
- +40 ;
- LOINC(A,B) ;
- +1 NEW %
- +2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
- +3 IF %]""
- IF $DATA(^ATXAX(B,21,"B",%))
- QUIT 1
- +4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
- +5 IF $DATA(^ATXAX(B,21,"B",%))
- QUIT 1
- +6 QUIT ""
- +7 ;
- FITDNA(P,BDATE,EDATE) ;EP
- +1 IF $GET(BDATE)=""
- SET BDATE=$EXTRACT(EDATE,1,3)-3_$EXTRACT(EDATE,4,7)
- +2 SET BUDD=""
- SET BUDLFOB=""
- +3 SET T=$ORDER(^ATXAX("B","BGP FIT-DNA LOINC CODES",0))
- +4 SET BUDLT=$ORDER(^ATXLAB("B","BGP FIT-DNA TESTS",0))
- +5 SET B=9999999-BDATE
- SET E=9999999-EDATE
- SET D=E-1
- FOR
- SET D=$ORDER(^AUPNVLAB("AE",P,D))
- IF D'=+D!(D>B)!(BUDD]"")
- QUIT
- Begin DoDot:1
- +6 SET L=0
- FOR
- SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
- IF L'=+L!(BUDD]"")
- QUIT
- Begin DoDot:2
- +7 SET X=0
- FOR
- SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
- IF X'=+X!(BUDD]"")
- QUIT
- Begin DoDot:3
- +8 IF '$DATA(^AUPNVLAB(X,0))
- QUIT
- +9 IF BUDLT
- IF $PIECE(^AUPNVLAB(X,0),U)
- IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
- SET BUDD="FIT-DNA: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDHDU(9999999-D)_U_(9999999-D)
- QUIT
- +10 IF 'T
- QUIT
- +11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
- IF J=""
- QUIT
- +12 IF '$$LOINC(J,T)
- QUIT
- +13 SET BUDD="FIT-DNA: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDHDU(9999999-D)_U_(9999999-D)
- QUIT
- +14 QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 SET BUDLFOB=BUDD
- +16 QUIT BUDLFOB
- CTC(P,BDATE,EDATE) ;EP
- +1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
- +2 IF $GET(BDATE)=""
- SET BDATE=$EXTRACT(EDATE,1,3)-5_$EXTRACT(EDATE,4,7)
- +3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
- +4 SET BUDTOB=""
- +5 SET TIEN=$ORDER(^BUDHTSSC("B","T6B CRC CT COLON CODES",0))
- +6 SET CTR=0
- FOR
- SET CTR=$ORDER(BUDVS(CTR))
- IF CTR'=+CTR!(BUDTOB]"")
- QUIT
- Begin DoDot:1
- +7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
- +8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
- +9 ;POV/SNOMED
- +10 SET X=0
- FOR
- SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
- IF X'=+X!(BUDTOB]"")
- QUIT
- Begin DoDot:2
- +11 IF '$DATA(^AUPNVPOV(X,0))
- QUIT
- +12 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
- IF $DATA(^BUDHTSSC("AD",Y,TIEN))
- SET BUDTOB="CTC: DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
- QUIT
- +13 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
- +14 IF Y=""
- QUIT
- +15 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
- SET BUDTOB="CTC: DX "_Y_":"_$$DATE^BUDHDU(VDATE)_U_VDATE
- QUIT
- End DoDot:2
- +16 ;CPT
- +17 SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
- IF X'=+X!(BUDTOB]"")
- QUIT
- Begin DoDot:2
- +18 IF '$DATA(^AUPNVCPT(X,0))
- QUIT
- +19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
- +20 IF Y=""
- QUIT
- +21 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
- SET BUDTOB="CTC: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDHDU(VDATE)_U_VDATE
- QUIT
- End DoDot:2
- +22 ;V TRANS
- +23 SET X=0
- FOR
- SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
- IF X'=+X!(BUDTOB]"")
- QUIT
- Begin DoDot:2
- +24 IF '$DATA(^AUPNVTC(X,0))
- QUIT
- +25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
- +26 IF Y=""
- QUIT
- +27 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
- SET BUDTOB="CTC: CPT "_Y_":"_$$DATE^BUDHDU(VDATE)_U_VDATE
- QUIT
- End DoDot:2
- +28 ;V PROC
- +29 SET X=0
- FOR
- SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
- IF X'=+X!(BUDTOB]"")
- QUIT
- Begin DoDot:2
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+32 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDTOB="CTC: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDHDU(VDATE)_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDTOB]""
QUIT BUDTOB
+34 QUIT ""
+35 ;----------
AGEF(DFN,APCLDT) ;EP
+1 ;---> Age formatted "35 Months" or "23 Years"
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - APCLDT (opt) Date on which Age should be calculated.
+5 ;
+6 NEW Y
+7 SET Y=$$AGE(DFN,2,$GET(APCLDT))
+8 IF Y["DECEASED"
QUIT Y
+9 IF Y["NOT BORN"
QUIT Y
+10 ;
+11 ;---> If over 60 months, return years.
+12 IF Y>60
SET Y=$$AGE(DFN,1,$GET(APCLDT))
QUIT Y_$SELECT(Y=1:"year",1:" yrs")
+13 ;
+14 ;---> If under 1 month return days.
+15 IF Y<1
SET Y=$$AGE(DFN,3,$GET(APCLDT))
QUIT Y_$SELECT(Y=1:" day",1:" days")
+16 ;
+17 ;---> Return months
+18 QUIT Y_$SELECT(Y=1:" mth",1:" mths")
+19 ;
+20 ;
+21 ;----------
DECEASED(DFN,APCLDT) ;EP
+1 ;---> Return 1 if patient is deceased, 0 if not deceased.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
+5 ;
+6 IF '$GET(DFN)
QUIT 0
+7 NEW X
SET X=+$GET(^DPT(DFN,.35))
+8 IF 'X
QUIT 0
+9 IF '$GET(APCLDT)
QUIT 1
+10 QUIT X
+11 ;
+12 ;
GETMEDS(P,BUDMBD,BUDMED,TAXM,TAXN,TAXC,BUDDNAME,BUDZ,TAXRN) ;EP
+1 SET TAXM=$GET(TAXM)
+2 SET TAXN=$GET(TAXN)
+3 SET TAXC=$GET(TAXC)
+4 SET TAXRXN=$GET(TAXRXN)
+5 KILL ^TMP($JOB,"MEDS"),BUDZ
+6 SET BUDDNAME=$GET(BUDDNAME)
+7 NEW BUDCC1,BUDINED,BUDINBD,BUDMIEN,BUDD,X,Y,T,T1,D,G
+8 SET BUDCC1=0
KILL BUDZ
+9 SET BUDINED=(9999999-BUDMED)-1
SET BUDINBD=(9999999-BUDMBD)
+10 FOR
SET BUDINED=$ORDER(^AUPNVMED("AA",P,BUDINED))
IF BUDINED=""!(BUDINED>BUDINBD)
QUIT
Begin DoDot:1
+11 SET BUDMIEN=0
FOR
SET BUDMIEN=$ORDER(^AUPNVMED("AA",P,BUDINED,BUDMIEN))
IF BUDMIEN'=+BUDMIEN
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVMED(BUDMIEN,0))
QUIT
+13 SET BUDD=$PIECE(^AUPNVMED(BUDMIEN,0),U)
+14 IF BUDD=""
QUIT
+15 IF '$DATA(^PSDRUG(BUDD,0))
QUIT
+16 SET BUDCC1=BUDCC1+1
+17 SET ^TMP($JOB,"MEDS","ORDER",(9999999-BUDINED),BUDCC1)=(9999999-BUDINED)_U_$PIECE(^PSDRUG(BUDD,0),U)_U_$PIECE(^PSDRUG(BUDD,0),U)_U_BUDMIEN_U_$PIECE(^AUPNVMED(BUDMIEN,0),U,3)
End DoDot:2
End DoDot:1
+18 ;reorder
+19 SET BUDCC1=0
SET X=0
+20 FOR
SET X=$ORDER(^TMP($JOB,"MEDS","ORDER",X))
IF X'=+X
QUIT
Begin DoDot:1
+21 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"MEDS","ORDER",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+22 SET BUDCC1=BUDCC1+1
+23 SET ^TMP($JOB,"MEDS",BUDCC1)=^TMP($JOB,"MEDS","ORDER",X,Y)
End DoDot:2
End DoDot:1
+24 KILL ^TMP($JOB,"MEDS","ORDER")
+25 SET T=""
IF TAXM]""
SET T=$ORDER(^ATXAX("B",TAXM,0))
+26 SET T1=""
IF TAXN]""
SET T1=$ORDER(^ATXAX("B",TAXN,0))
+27 SET T2=""
IF TAXC]""
SET T2=$ORDER(^ATXAX("B",TAXC,0))
+28 SET T3=""
IF TAXRXN]""
SET T3=$ORDER(^ATXAX("B",TAXRXN,0))
+29 SET BUDCC1=0
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+30 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+31 SET G=0
+32 SET D=$PIECE(^AUPNVMED(Y,0),U)
+33 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+34 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
+35 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
+36 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",C))
SET G=1
+37 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",$$STRIP^XLFSTR(C,"-")))
SET G=1
+38 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+39 IF BUDDNAME]""
IF $PIECE(^PSDRUG(D,0),U)[BUDDNAME
SET G=1
+40 SET C=$$VAL^XBDIQ1(9000010.14,Y,9999999.27)
+41 IF C]""
IF T3
IF $DATA(^ATXAX(T3,21,"B",C))
SET G=1
+42 ;WANTS ALL MEDS
IF TAXM=""
IF TAXN=""
IF TAXC=""
SET G=1
+43 IF G=1
SET BUDCC1=BUDCC1+1
SET BUDZ(BUDCC1)=^TMP($JOB,"MEDS",X)
+44 QUIT
End DoDot:1
+45 KILL ^TMP($JOB,"MEDS")
+46 KILL BUDINED,BUDINBD,BUDMBD,BUDMED,BUDD,BUDCC1,BUDDNAME
+47 QUIT
HL(P,BD,ED) ;EP - was patient homeless on any day in this time period?
+1 IF '$ORDER(^AUPNPAT(P,85,0))
QUIT ""
+2 ;SET UP ARRAY OF DATES OF HOMELESSNESS
+3 NEW X,Y,Z,N,B,C,A
+4 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(P,85,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,85,"B",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)=""
QUIT
+7 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)="N"
QUIT
+8 ;okay is homeless until the next value of "N" or DT if none found
+9 SET N=X
SET A=""
FOR
SET N=$ORDER(^AUPNPAT(P,85,"B",N))
IF N'=+N!(A)
QUIT
Begin DoDot:3
+10 SET B=0
FOR
SET B=$ORDER(^AUPNPAT(P,85,"B",N,B))
IF B'=+B!(A)
QUIT
Begin DoDot:4
+11 IF $PIECE($GET(^AUPNPAT(P,85,B,0)),U,2)=""
QUIT
+12 IF $PIECE($GET(^AUPNPAT(P,85,B,0)),U,2)="Y"
QUIT
+13 ;so is homeless from X TO A
SET A=N
End DoDot:4
End DoDot:3
+14 IF 'A
SET A=DT
+15 SET Z(X)=X_U_$$FMADD^XLFDT(A,-1)
End DoDot:2
End DoDot:1
+16 ;CHECK EACH ONE TO SEE IF ANY ENCOMPASS BD TO ED
SET X=0
+17 SET Y=0
FOR
SET Y=$ORDER(Z(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+18 SET B=$PIECE(Z(Y),U,1)
+19 SET E=$PIECE(Z(Y),U,2)
+20 ;begins after end date of report period
IF B>ED
QUIT
+21 ;ends before report period
IF E<BD
QUIT
+22 SET X=1
End DoDot:1
+23 QUIT X
ALLCPT(P,BD,ED,T,A) ;EP - ALL CPTS IN A DATE RANGE IN TAXONOMY T
+1 ;P - patient
+2 ;BD - beginning date
+3 ;ED - ending date
+4 ;T - taxonomy IEN
+5 ;return all CPTSthat match in array A
+6 ;FORMAT: 1^DATE^CPT CODE EXTERNAL^V CPT IEN^VISIT IEN
+7 SET T=$GET(T)
+8 IF 'T
QUIT
+9 NEW D,V,G,X,J,B,E,BUDC,CPTTAX
+10 ;UNFOLD TAXONOMY
+11 DO BLDTAX^ATXAPI($PIECE(^ATXAX(T,0),U,1),"CPTTAX",T,"")
+12 SET BUDC=0
+13 SET J=0
FOR
SET J=$ORDER(CPTTAX(J))
IF J=""
QUIT
Begin DoDot:1
+14 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+15 SET D=E-1
SET D=D_".9999"
SET G=0
FOR
SET D=$ORDER(^AUPNVCPT("AA",P,J,D))
IF D'=+D!($PIECE(D,".")>B)
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AA",P,J,D,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET BUDC=BUDC+1
+18 SET @A@(BUDC)=(9999999-$PIECE(D,"."))_"^"_$PIECE(CPTTAX(J),U,1)_"^"_X_"^"_$PIECE($GET(^AUPNVCPT(X,0)),U,3)
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
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
+2 ;NO SNOMED STUFF INSTALLED
IF $TEXT(SUBLST^BSTSAPI)=""
GOTO DX
+3 ;
+4 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDHTSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+5 ;no snomed subset
IF $PIECE(^BUDHTSSC(BUDX,0),U,2)=""
QUIT
+6 ;delete all old snomed entries for this entry
+7 SET BUDI=0
FOR
SET BUDI=$ORDER(^BUDHTSSC(BUDX,13,BUDI))
IF BUDI'=+BUDI
QUIT
Begin DoDot:2
+8 KILL DIC,DR,DA
SET DA(1)=BUDX
SET DA=BUDI
SET DIE="^BUDHTSSC("_BUDX_",13,"
SET DR=".01///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+9 KILL ^TMP($JOB,"SUB")
+10 SET OUT=$NAME(^TMP($JOB,"SUB"))
+11 SET N=$PIECE(^BUDHTSSC(BUDX,0),U,2)
+12 ;
SET X=$$SUBLST^BSTSAPI(OUT,N)
+13 ;BUILD INDEX
+14 SET C=0
FOR
SET C=$ORDER(^TMP($JOB,"SUB",C))
IF C'=+C
QUIT
SET I=$PIECE(^TMP($JOB,"SUB",C),U,1)
IF I]""
SET ^BUDHTSSC(BUDX,13,C,0)=I
+15 KILL DIK,DA
SET DA=BUDX
SET DIK="^BUDHTSSC("
DO IX1^DIK
KILL DIK,DA
End DoDot:1
DX ;
+1 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDHTSSC(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+2 ;no DX TAXONOMY
IF $PIECE(^BUDHTSSC(BUDX,0),U,3)=""
QUIT
+3 ;delete all old ICD entries for this entry
+4 SET BUDI=0
FOR
SET BUDI=$ORDER(^BUDHTSSC(BUDX,11,BUDI))
IF BUDI'=+BUDI
QUIT
Begin DoDot:2
+5 KILL DIC,DR,DA
SET DA(1)=BUDX
SET DA=BUDI
SET DIE="^BUDHTSSC("_BUDX_",11,"
SET DR=".01///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+6 SET BUDTGT="BUDTAX"
+7 DO BLDTAX^ATXAPI($PIECE(^BUDHTSSC(BUDX,0),U,3),BUDTGT,$ORDER(^ATXAX("B",$PIECE(^BUDHTSSC(BUDX,0),U,3),0)))
+8 ;BUILD INDEX
+9 SET C=0
SET X=0
FOR
SET X=$ORDER(BUDTAX(X))
IF X'=+X
QUIT
Begin DoDot:2
+10 SET C=C+1
+11 SET ^BUDHTSSC(BUDX,11,C,0)=$PIECE(BUDTAX(X),U,1)_U_X_U_$PIECE(BUDTAX(X),U,3)
End DoDot:2
+12 SET ^BUDHTSSC(BUDX,1,0)="^90669.90811^"_C_"^"_C
+13 KILL DIK,DA
SET DA=BUDX
SET DIK="^BUDHTSSC("
DO IX1^DIK
KILL DIK,DA
End DoDot:1
+14 QUIT