BHSMEA ;IHS/CIA/MGH - Health Summary for Measurements and immunizations ;30-Nov-2015 10:26;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,5,7,9,12**;March 17, 2006;Build 3
;===================================================================
;Taken from APCHS2
; IHS/TUCSON/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**2,3**;JUN 24, 1997
;IHS/CMI/LAB - patch 2 fixed AGE subroutine
;IHS/CMI/LAB - patch 3 new imm package
;Creation of VA health summary components from IHS health summary components
;for V measurement file and immunizations
;Patch 2 for patch 16 and CVS changes
;Patch 3 to fix a bug in the display
;Patch 4 added qualifiers for vitals
;Patch 5 fixed a bug with items with / in them
;Patch 12 Used new API for taxonomies
;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
; <SETUP>
N BHSPAT,Y,ARRAY
S BHSPAT=DFN
Q:'$D(^AUPNVMSR("AA",BHSPAT))
; <DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT) W !
S BHSMT="" F BHSQ=0:0 S BHSMT=$O(^AUPNVMSR("AA",BHSPAT,BHSMT)) Q:BHSMT="" S BHSND2=GMTSNDM D MEASDTYP Q:$D(GMTSQIT)
D WRTOUT
; <CLEANUP>
MEASX K BHSMT,BHSMT2,BHSMT3,BHSDFN,BHSND2,BHSDAT
Q
MEASDTYP S BHSMT2=$S($D(^AUTTMSR(BHSMT,0)):$P(^(0),U,1),1:BHSMT) S BHSMT3=BHSMT2
S (BHSIVD,BHSDFN)="" F S BHSIVD=$O(^AUPNVMSR("AA",BHSPAT,BHSMT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) S BHSND2=BHSND2-1 Q:BHSND2=-1 D MEASDSP
I BHSMT3="" D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q
MEASDSP ;
;IHS/MSC/MGH changed lookup o find more than one vital during a visit
;Patch 3 fixed a bug in display of items with a / in them
N DATA,V,T,BHSDAT2
S BHSDFN="" F S BHSDFN=$O(^AUPNVMSR("AA",BHSPAT,BHSMT,BHSIVD,BHSDFN)) Q:BHSDFN="" D
.Q:$P($G(^AUPNVMSR(BHSDFN,2)),U,1) ;entered in error
.S V=$P(^AUPNVMSR(BHSDFN,0),U,3) Q:$P($G(^AUPNVSIT(V,0)),U,7)="H" ;exclude inpatient
.S BHSDAT=$P($G(^AUPNVMSR(BHSDFN,12)),U,1) S X=BHSDAT
.I BHSDAT="" S (X,BHSDAT)=-BHSIVD\1+9999999
.D REGDTM^GMTSU
.S BHSDAT2=X
.S ARRAY(BHSMT2,BHSDAT)=BHSDFN_"^"_BHSDAT2
Q
WRTOUT ;Write out the vitals
N I,BHSDAT,BHSDFN,BHSDAT2,BHSMT,BHSX,PO2,PREG
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSMT2=""
S BHSMT="" F S BHSMT=$O(ARRAY(BHSMT)) Q:BHSMT="" D
.I BHSMT'=BHSMT2 W !,BHSMT S BHSMT2=BHSMT
.S BHSDAT="" F S BHSDAT=$O(ARRAY(BHSMT,BHSDAT)) Q:BHSDAT="" D
..S BHSDFN=$P($G(ARRAY(BHSMT,BHSDAT)),U,1)
..S BHSDAT2=$P($G(ARRAY(BHSMT,BHSDAT)),U,2)
..;W:GMTSNPG!(BHSMT3]"") BHSMT2 S BHSMT3="" W ?5,BHSDAT2
..W ?5,BHSDAT2
..S DATA=$P($G(^AUPNVMSR(BHSDFN,0)),U,4)
..I $P(DATA,".",2)'="" S DATA=+$J(DATA,0,2)
..I BHSMT="BMI" D
...S PREG=$$PREG(DFN,"",BHSDFN)
...I PREG=1 S DATA=DATA_"*"
..W ?22,DATA
..I BHSMT="O2" D
...S PO2=$P($G(^AUPNVMSR(BHSDFN,0)),U,10)
...W ?32,"Supplemental O2: "_PO2,!
..I '$O(^AUPNVMSR(BHSDFN,5,0)) W ! Q ;no qualifiers
..S C=0,X=0,D=0 F S X=$O(^AUPNVMSR(BHSDFN,5,X)) Q:X'=+X S C=C+1
..W ?32,"Qualifier"_$S(C>1:"s",1:""),":"
..S T="" S BHSX=0 F S BHSX=$O(^AUPNVMSR(BHSDFN,5,BHSX)) D Q:BHSX'=+BHSX
...S Y=$P($G(^AUPNVMSR(BHSDFN,5,BHSX,0)),U) I Y D
....S D=D+1
....I T'="" S T=T_", "
....S T=T_$P($G(^GMRD(120.52,Y,0)),U,1)
....I D>1 W ?45,T,! S D=0,T=""
..W ?45,T
..W !
Q
PREG(DFN,VIEN,VMIEN) ;Determine if BMI is for pregnant patient
N DOB,X1,X1,TAGE,POV,CODE,TAX,RET
S RET=0
S VMIEN=$G(VMIEN),VIEN=$G(VIEN)
I $$GET1^DIQ(2,DFN,.02,"I")'="F" Q RET ;Wrong sex
S TAGE=$$GET1^DIQ(2,DFN,.033)
I TAGE<10!(TAGE>50) Q RET ;Wrong age
;Find POVs on this visit and check if they are pregnancy POVs
I VIEN="" D
.S VIEN=$$GET1^DIQ(9000010.01,VMIEN,.03,"I")
I '+VIEN Q RET
S TAX=$O(^ATXAX("B","BQI PREGNANCY DXS",0))
S POV="" F S POV=$O(^AUPNVPOV("AD",VIEN,POV)) Q:POV=""!(RET=1) D
.S CODE=$$GET1^DIQ(9000010.07,POV,.01,"I")
.I CODE="" Q
.;IHS/MSC/MGH Patch 11
.S RET=$$ICD^ATXAPI(CODE,TAX,9)
Q RET
;
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
N BHSPAT,BHSP,BHSQ,Y
S BHSPAT=DFN
I +$$VER^BILOGO>7 D IMMBI2 Q ;IHS/CMI/MWR 8/19/03, for Immunization v8.x
I $$BI D IMMBI Q ;IHS/CMI/LAB - new imm package
; <SETUP>
Q:'$D(^AUPNVIMM("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSITP="" F BHSQ=0:0 S BHSITP=$O(^AUPNVIMM("AA",BHSPAT,BHSITP)) Q:BHSITP="" D IMMDTYP
; <CLEANUP>
REF ;Patch 2 display refusals/contraindications
S BHY=0 F S BHY=$O(^BIPC("AC",BHSPAT,BHY)) Q:BHY'=+BHY D
.S BHX=0 F S BHX=$O(^BIPC("AC",BHSPAT,BHY,BHX)) Q:BHX'=+BHX D
..S R=$P(^BIPC(BHX,0),U,3)
..Q:R=""
..Q:'$D(^BICONT(R,0))
..Q:$P(^BICONT(R,0),U,1)'["Refusal"
..S D=$P(^BIPC(BHX,0),U,4)
..Q:D=""
..S D=9999999-D
..Q:D>GMTSDLM
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,$$VAL^XBDIQ1(9002084.11,BHX,.02)," -- ",$$VAL^XBDIQ1(9002084.11,BHX,.03),?60,"(",$$DATE^BHSMU($P(^BIPC(BHX,0),U,4)),")"
..Q
.Q
S BHSFN=9999999.14,BHST="" D DISPREF^BHSRAD
K BHSFN,BHST,BHSS
IMMUNX K BHSITP,BHSITX,BHSITL,BHSDFN,BHSDAT,BHSIVD,BHSVDF,BHX,BHY,R,D
K BHSIMC,BHSIMR,BHSN,BHSIC,BHSIR,BHSDAT2
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE
Q
IMMDTYP S BHSITX=$P(^AUTTIMM(BHSITP,0),U,2),BHSITL=$L(BHSITX) D CKP^GMTSUP Q:$D(GMTSQIT) D
.W ! D CKP^GMTSUP Q:$D(GMTSQIT) W BHSITX S BHSIVD=""
.F BHSQ=0:0 S BHSIVD=$O(^AUPNVIMM("AA",BHSPAT,BHSITP,BHSIVD)) Q:'BHSIVD D IMMDSP
Q
IMMDSP S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVIMM("AA",BHSPAT,BHSITP,BHSIVD,BHSDFN)) Q:BHSDFN="" D IMMDSP2
Q
IMMDSP2 S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDAT2=$P($G(^AUPNVMSR(BHSPAT,12)),U,1)
S X=BHSDAT2 D REGDT4^GMTSU S BHSDAT2=X
S BHSN=^AUPNVIMM(BHSDFN,0)
S BHSVDF=$P(BHSN,U,3) D GETSITEV^BHSUTL S BHSITE=BHSNSH
S X=$P(BHSN,U,6),Y=.06 D IMMGSET S BHSIR=BHSP
S X=$P(BHSN,U,7),Y=.07 D IMMGSET S BHSIC=BHSP S:BHSIC]"" BHSIC="DO NOT REPEAT"
I BHSIC]"",BHSIR]"" S BHSIR=BHSIR_"; "
S BHSIR=BHSIR_BHSIC
;modified following line - LAB
I BHSDAT2'="" S BHSDAT=BHSDAT2
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG BHSITX W ?(BHSITL+1),$P(^AUPNVIMM(BHSDFN,0),U,4),?15,BHSDAT,?25,$$AGE(BHSPAT,$P(+^AUPNVSIT(BHSVDF,0),"."),"P"),?34,BHSITE,?65,BHSIR,!
Q
IMMGSET S Y=$G(^DD(9000010.11,Y,0)),Y=$P(Y,U,3)
S:'X Y=""
F BHSQ=1:1 S BHSP=$P(Y,";",BHSQ) Q:BHSP="" I $P(BHSP,":",1)=X S BHSP=$P(BHSP,":",2) Q
Q
;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
Q $S($O(^AUTTIMM(0))<100:0,1:1)
;-----------
AGE(DFN,D,F) ;(DFN) Given DFN, return Age. ; AUPN*93.2*3
I '$G(DFN) Q -1
I '$D(^DPT(DFN,0)) Q -1
I $$DOB^AUPNPAT(DFN)<0 Q -1
S:$G(D)="" D=DT
S:$G(F)="" F="Y"
NEW %
S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN))
I F="Y" Q %\365.25
;beginning Y2K
;NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
;end Y2000
Q %
;
;
IMMBI ;IHS/CMI/LAB - new subroutine for new imm package
D CKP^GMTSUP Q:$D(GMTSQIT)
;
;
;
NEW APCH31,APCHIMM,APCHBIER
S APCH31=$C(31)_$C(31),APCHIMM=""
D IMMFORC^BIRPC(.APCHIMM,BHSPAT)
;
W ?3,"IMMUNIZATION FORECAST:",!!
;
D
.;---> Check for error in 2nd piece of return value.
.S APCHBIER=$P(APCHIMM,APCH31,2)
.;---> If there's an error, display it and quit.
.I APCHBIER]"" D CKP^GMTSUP Q:$D(GMTSQIT) D Q
..D EN^DDIOL("* "_APCHBIER,"","?5") W !
.;
.;---> No error, so take 1st piece of return value and process it.
.S APCHIMM=$P(APCHIMM,APCH31,1)
.;
.NEW APCHX,APCHI F APCHX=1:1 S APCHI=$P(APCHIMM,"^",APCHX) Q:APCHI=""!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ?3,$P(APCHI,"|"),?23,$P(APCHI,"|",2),?36,$P(APCHI,"|",3),!
..Q
;
CONTRAS ;
;
N APCHCONT S APCHCONT=""
;
;---> RPC to retrieve Contraindications.
D CONTRAS^BIRPC5(.APCHCONT,BHSPAT)
;
;---> If APCHBIER has a value, display it and quit.
S APCHBIER=$P(APCHCONT,APCH31,2)
I APCHBIER]"" D CKP^GMTSUP Q:$D(GMTSQIT) D EN^DDIOL("* "_APCHBIER,"","!!?5") G HX
;
;---> Set APCHC=to a string of Contraindications for this patient.
N APCHC S APCHC=$P(APCHCONT,APCH31,1)
I APCHC]"" D CKP^GMTSUP Q:$D(GMTSQIT) W !
;
;---> Build Listmanager array from APCHC string.
;
F I=1:1 S Y=$P(APCHC,U,I) Q:Y="" D
.;---> Build display line for this Contraindication.
.N V S V="|",X=" "
.S:I=1 X=X_"* Contraindications:" S X=$$PAD(X,28)
.;
.;---> Display "Vaccine: Date Reason"
.S X=X_$P(Y,V,2)_":",X=$$PAD(X,40)_$P(Y,V,4)
.S X=$$PAD(X,53)_$P(Y,V,3)
.;---> Set formatted Contraindication line and index in ^TMP.
.D CKP^GMTSUP Q:$D(GMTSQIT) W X,!
.Q
;
;
;
HX ;
NEW APCHBIDE,I F I=8,26,27,60,33,44,57 S APCHBIDE(I)=""
;call to get imm hx
D IMMHX^BIRPC(.APCHIMM,BHSPAT,.APCHBIDE)
W !?3,"IMMUNIZATION HISTORY:",!
;
S APCHBIER=$P(APCHIMM,APCH31,2)
I APCHBIER]"" D CKP^GMTSUP Q:$D(GMTSQIT) D EN^DDIOL("* "_APCHBIER,"","!!?5") Q
S APCHIMM=$P(APCHIMM,APCH31,1)
NEW APCHI,APCHV,APCHX,APCHY,APCHZ
S APCHZ="",APCHV="|"
F APCHI=1:1 S APCHY=$P(APCHIMM,U,APCHI) Q:APCHY=""!($D(GMTSQIT)) D
.Q:$P(APCHY,APCHV)'="I"
.I $P(APCHY,APCHV,4)'=APCHZ D CKP^GMTSUP Q:$D(GMTSQIT) W ! S APCHZ=$P(APCHY,APCHV,4)
.NEW X,BHSDG K %DT S X=$P(APCHY,APCHV,8),%DT="P" D ^%DT S BHSDG=Y
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?3,$P(APCHY,APCHV,2),?22,$P(APCHY,APCHV,8),?34,$$AGE(BHSPAT,BHSDG,"P"),?45,$E($P(APCHY,APCHV,3),1,20),?66,$P(APCHY,APCHV,5),!
.I $P(APCHY,APCHV,6)]"" W ?22,"Reaction: ",$P(APCHY,APCHV,6),!
.Q
;----------
K APCHIMM,APCHY,APCHV,APCHBIDE,APCHZ
Q
;
;
;----------
PAD(D,L,C) ;EP
;---> Pad the length of data to a total of L characters
;---> by adding spaces to the end of the data.
; Example: S X=$$PAD("MIKE",7) X="MIKE " (Added 3 spaces.)
;---> Parameters:
; 1 - D (req) Data to be padded.
; 2 - L (req) Total length of resulting data.
; 3 - C (opt) Character to pad with (default=space).
;
Q:'$D(D) ""
S:'$G(L) L=$L(D)
S:$G(C)="" C=" "
Q $E(D_$$REPEAT^XLFSTR(C,L),1,L)
;
;
;----------
IMMBI2 ;EP
;---> Call to Immunization Package v8.x to build local array of formatted
;---> lines for Imm Health Summary Component. ;IHS/CMI/MWR 8/19/03
;---> Mike Remillard
;
D CKP^GMTSUP Q:$D(GMTSQIT) D CKP^GMTSUP
N BHSARR S BHSARR=""
D IMMBI^BIAPCHS(BHSPAT,.BHSARR)
;IHS/MSC/MGH
;Changes for APCH patch 14 included in patch 1
N N,F
S N=0,F=0
F S N=$O(^BHSARR(N)) Q:'N D
.Q:BHSARR(N,0)["IMMUNIZATION HISTORY:"
.I BHSARR(N,0)["VARICALLA" S F=1 ;varicella forecast as due
.Q
S N=0
F S N=$O(BHSARR(N)) Q:'N D D CKP^GMTSUP Q:$D(GMTSQIT)
.I BHSARR(N,0)["IMMUNIZATION HISTORY" D
..I F S X=$$PHCP(BHSPAT) I X]"" D
...W !,"Patient has a HX of chicken pox not yet entered as a contraindication"
...W !,"in the Immunization Package."
...W !,X,!!
.W BHSARR(N,0),!
D KILLALL^BIUTL8()
Q
PHCP(P) ;EP
;is there a personal history of chicken pox or is chicken pox on the problem list
NEW X,Y,Z,I,G
S G="",X=0 F S X=$O(^AUPNPH("AC",P,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNPH(X,0))
.S I=$P(^AUPNPH(X,0),U)
.Q:I=""
.;S I=$P($G(^ICD9(I,0)),U)
.;Patch 9 for ICD-10
.I $$AICD^BHSUTL S I=$P($$ICDDX^ICDEX(I,"","","I"),U,2)
.E S I=$P($$ICDDX^ICDCODE(I),U,2) ;code set versioning
.Q:$E(I,1,3)'="052"
.S G=X
.Q
I G Q "Personal History: "_I_" - "_$$VAL^XBDIQ1(9000013,G,.04)
;now check problem list
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNPROB(X,0))
.S I=$P(^AUPNPROB(X,0),U)
.Q:I=""
.;S I=$P($G(^ICD9(I,0)),U)
.;Patch 9 for ICD-10
.I $$AICD^BHSUTL S I=$P($$ICDDX^ICDEX(I,"","","I"),U,2)
.E S I=$P($$ICDDX^ICDCODE(I),U,2) ;code set versioning
.Q:$E(I,1,3)'="052"
.S G=X
.Q
I G Q "Problem List: "_I_" - "_$$VAL^XBDIQ1(9000011,G,.05)
Q ""
BHSMEA ;IHS/CIA/MGH - Health Summary for Measurements and immunizations ;30-Nov-2015 10:26;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,5,7,9,12**;March 17, 2006;Build 3
+2 ;===================================================================
+3 ;Taken from APCHS2
+4 ; IHS/TUCSON/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;**2,3**;JUN 24, 1997
+6 ;IHS/CMI/LAB - patch 2 fixed AGE subroutine
+7 ;IHS/CMI/LAB - patch 3 new imm package
+8 ;Creation of VA health summary components from IHS health summary components
+9 ;for V measurement file and immunizations
+10 ;Patch 2 for patch 16 and CVS changes
+11 ;Patch 3 to fix a bug in the display
+12 ;Patch 4 added qualifiers for vitals
+13 ;Patch 5 fixed a bug with items with / in them
+14 ;Patch 12 Used new API for taxonomies
+15 ;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
+1 ; <SETUP>
+2 NEW BHSPAT,Y,ARRAY
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVMSR("AA",BHSPAT))
QUIT
+5 ; <DISPLAY>
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
+7 SET BHSMT=""
FOR BHSQ=0:0
SET BHSMT=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSMT))
IF BHSMT=""
QUIT
SET BHSND2=GMTSNDM
DO MEASDTYP
IF $DATA(GMTSQIT)
QUIT
+8 DO WRTOUT
+9 ; <CLEANUP>
MEASX KILL BHSMT,BHSMT2,BHSMT3,BHSDFN,BHSND2,BHSDAT
+1 QUIT
MEASDTYP SET BHSMT2=$SELECT($DATA(^AUTTMSR(BHSMT,0)):$PIECE(^(0),U,1),1:BHSMT)
SET BHSMT3=BHSMT2
+1 SET (BHSIVD,BHSDFN)=""
FOR
SET BHSIVD=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSMT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
SET BHSND2=BHSND2-1
IF BHSND2=-1
QUIT
DO MEASDSP
+2 IF BHSMT3=""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
+3 QUIT
MEASDSP ;
+1 ;IHS/MSC/MGH changed lookup o find more than one vital during a visit
+2 ;Patch 3 fixed a bug in display of items with a / in them
+3 NEW DATA,V,T,BHSDAT2
+4 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSMT,BHSIVD,BHSDFN))
IF BHSDFN=""
QUIT
Begin DoDot:1
+5 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BHSDFN,2)),U,1)
QUIT
+6 ;exclude inpatient
SET V=$PIECE(^AUPNVMSR(BHSDFN,0),U,3)
IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="H"
QUIT
+7 SET BHSDAT=$PIECE($GET(^AUPNVMSR(BHSDFN,12)),U,1)
SET X=BHSDAT
+8 IF BHSDAT=""
SET (X,BHSDAT)=-BHSIVD\1+9999999
+9 DO REGDTM^GMTSU
+10 SET BHSDAT2=X
+11 SET ARRAY(BHSMT2,BHSDAT)=BHSDFN_"^"_BHSDAT2
End DoDot:1
+12 QUIT
WRTOUT ;Write out the vitals
+1 NEW I,BHSDAT,BHSDFN,BHSDAT2,BHSMT,BHSX,PO2,PREG
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 SET BHSMT2=""
+4 SET BHSMT=""
FOR
SET BHSMT=$ORDER(ARRAY(BHSMT))
IF BHSMT=""
QUIT
Begin DoDot:1
+5 IF BHSMT'=BHSMT2
WRITE !,BHSMT
SET BHSMT2=BHSMT
+6 SET BHSDAT=""
FOR
SET BHSDAT=$ORDER(ARRAY(BHSMT,BHSDAT))
IF BHSDAT=""
QUIT
Begin DoDot:2
+7 SET BHSDFN=$PIECE($GET(ARRAY(BHSMT,BHSDAT)),U,1)
+8 SET BHSDAT2=$PIECE($GET(ARRAY(BHSMT,BHSDAT)),U,2)
+9 ;W:GMTSNPG!(BHSMT3]"") BHSMT2 S BHSMT3="" W ?5,BHSDAT2
+10 WRITE ?5,BHSDAT2
+11 SET DATA=$PIECE($GET(^AUPNVMSR(BHSDFN,0)),U,4)
+12 IF $PIECE(DATA,".",2)'=""
SET DATA=+$JUSTIFY(DATA,0,2)
+13 IF BHSMT="BMI"
Begin DoDot:3
+14 SET PREG=$$PREG(DFN,"",BHSDFN)
+15 IF PREG=1
SET DATA=DATA_"*"
End DoDot:3
+16 WRITE ?22,DATA
+17 IF BHSMT="O2"
Begin DoDot:3
+18 SET PO2=$PIECE($GET(^AUPNVMSR(BHSDFN,0)),U,10)
+19 WRITE ?32,"Supplemental O2: "_PO2,!
End DoDot:3
+20 ;no qualifiers
IF '$ORDER(^AUPNVMSR(BHSDFN,5,0))
WRITE !
QUIT
+21 SET C=0
SET X=0
SET D=0
FOR
SET X=$ORDER(^AUPNVMSR(BHSDFN,5,X))
IF X'=+X
QUIT
SET C=C+1
+22 WRITE ?32,"Qualifier"_$SELECT(C>1:"s",1:""),":"
+23 SET T=""
SET BHSX=0
FOR
SET BHSX=$ORDER(^AUPNVMSR(BHSDFN,5,BHSX))
Begin DoDot:3
+24 SET Y=$PIECE($GET(^AUPNVMSR(BHSDFN,5,BHSX,0)),U)
IF Y
Begin DoDot:4
+25 SET D=D+1
+26 IF T'=""
SET T=T_", "
+27 SET T=T_$PIECE($GET(^GMRD(120.52,Y,0)),U,1)
+28 IF D>1
WRITE ?45,T,!
SET D=0
SET T=""
End DoDot:4
End DoDot:3
IF BHSX'=+BHSX
QUIT
+29 WRITE ?45,T
+30 WRITE !
End DoDot:2
End DoDot:1
+31 QUIT
PREG(DFN,VIEN,VMIEN) ;Determine if BMI is for pregnant patient
+1 NEW DOB,X1,X1,TAGE,POV,CODE,TAX,RET
+2 SET RET=0
+3 SET VMIEN=$GET(VMIEN)
SET VIEN=$GET(VIEN)
+4 ;Wrong sex
IF $$GET1^DIQ(2,DFN,.02,"I")'="F"
QUIT RET
+5 SET TAGE=$$GET1^DIQ(2,DFN,.033)
+6 ;Wrong age
IF TAGE<10!(TAGE>50)
QUIT RET
+7 ;Find POVs on this visit and check if they are pregnancy POVs
+8 IF VIEN=""
Begin DoDot:1
+9 SET VIEN=$$GET1^DIQ(9000010.01,VMIEN,.03,"I")
End DoDot:1
+10 IF '+VIEN
QUIT RET
+11 SET TAX=$ORDER(^ATXAX("B","BQI PREGNANCY DXS",0))
+12 SET POV=""
FOR
SET POV=$ORDER(^AUPNVPOV("AD",VIEN,POV))
IF POV=""!(RET=1)
QUIT
Begin DoDot:1
+13 SET CODE=$$GET1^DIQ(9000010.07,POV,.01,"I")
+14 IF CODE=""
QUIT
+15 ;IHS/MSC/MGH Patch 11
+16 SET RET=$$ICD^ATXAPI(CODE,TAX,9)
End DoDot:1
+17 QUIT RET
+18 ;
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
+1 NEW BHSPAT,BHSP,BHSQ,Y
+2 SET BHSPAT=DFN
+3 ;IHS/CMI/MWR 8/19/03, for Immunization v8.x
IF +$$VER^BILOGO>7
DO IMMBI2
QUIT
+4 ;IHS/CMI/LAB - new imm package
IF $$BI
DO IMMBI
QUIT
+5 ; <SETUP>
+6 IF '$DATA(^AUPNVIMM("AA",BHSPAT))
QUIT
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 ; <DISPLAY>
+9 SET BHSITP=""
FOR BHSQ=0:0
SET BHSITP=$ORDER(^AUPNVIMM("AA",BHSPAT,BHSITP))
IF BHSITP=""
QUIT
DO IMMDTYP
+10 ; <CLEANUP>
REF ;Patch 2 display refusals/contraindications
+1 SET BHY=0
FOR
SET BHY=$ORDER(^BIPC("AC",BHSPAT,BHY))
IF BHY'=+BHY
QUIT
Begin DoDot:1
+2 SET BHX=0
FOR
SET BHX=$ORDER(^BIPC("AC",BHSPAT,BHY,BHX))
IF BHX'=+BHX
QUIT
Begin DoDot:2
+3 SET R=$PIECE(^BIPC(BHX,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+7 SET D=$PIECE(^BIPC(BHX,0),U,4)
+8 IF D=""
QUIT
+9 SET D=9999999-D
+10 IF D>GMTSDLM
QUIT
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 WRITE !,$$VAL^XBDIQ1(9002084.11,BHX,.02)," -- ",$$VAL^XBDIQ1(9002084.11,BHX,.03),?60,"(",$$DATE^BHSMU($PIECE(^BIPC(BHX,0),U,4)),")"
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 SET BHSFN=9999999.14
SET BHST=""
DO DISPREF^BHSRAD
+16 KILL BHSFN,BHST,BHSS
IMMUNX KILL BHSITP,BHSITX,BHSITL,BHSDFN,BHSDAT,BHSIVD,BHSVDF,BHX,BHY,R,D
+1 KILL BHSIMC,BHSIMR,BHSN,BHSIC,BHSIR,BHSDAT2
+2 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE
+3 QUIT
IMMDTYP SET BHSITX=$PIECE(^AUTTIMM(BHSITP,0),U,2)
SET BHSITL=$LENGTH(BHSITX)
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:1
+1 WRITE !
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSITX
SET BHSIVD=""
+2 FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVIMM("AA",BHSPAT,BHSITP,BHSIVD))
IF 'BHSIVD
QUIT
DO IMMDSP
End DoDot:1
+3 QUIT
IMMDSP SET BHSDFN=0
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVIMM("AA",BHSPAT,BHSITP,BHSIVD,BHSDFN))
IF BHSDFN=""
QUIT
DO IMMDSP2
+1 QUIT
IMMDSP2 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+1 SET BHSDAT2=$PIECE($GET(^AUPNVMSR(BHSPAT,12)),U,1)
+2 SET X=BHSDAT2
DO REGDT4^GMTSU
SET BHSDAT2=X
+3 SET BHSN=^AUPNVIMM(BHSDFN,0)
+4 SET BHSVDF=$PIECE(BHSN,U,3)
DO GETSITEV^BHSUTL
SET BHSITE=BHSNSH
+5 SET X=$PIECE(BHSN,U,6)
SET Y=.06
DO IMMGSET
SET BHSIR=BHSP
+6 SET X=$PIECE(BHSN,U,7)
SET Y=.07
DO IMMGSET
SET BHSIC=BHSP
IF BHSIC]""
SET BHSIC="DO NOT REPEAT"
+7 IF BHSIC]""
IF BHSIR]""
SET BHSIR=BHSIR_"; "
+8 SET BHSIR=BHSIR_BHSIC
+9 ;modified following line - LAB
+10 IF BHSDAT2'=""
SET BHSDAT=BHSDAT2
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE BHSITX
WRITE ?(BHSITL+1),$PIECE(^AUPNVIMM(BHSDFN,0),U,4),?15,BHSDAT,?25,$$AGE(BHSPAT,$PIECE(+^AUPNVSIT(BHSVDF,0),"."),"P"),?34,BHSITE,?65,BHSIR,!
+12 QUIT
IMMGSET SET Y=$GET(^DD(9000010.11,Y,0))
SET Y=$PIECE(Y,U,3)
+1 IF 'X
SET Y=""
+2 FOR BHSQ=1:1
SET BHSP=$PIECE(Y,";",BHSQ)
IF BHSP=""
QUIT
IF $PIECE(BHSP,":",1)=X
SET BHSP=$PIECE(BHSP,":",2)
QUIT
+3 QUIT
+4 ;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
+2 ;-----------
AGE(DFN,D,F) ;(DFN) Given DFN, return Age. ; AUPN*93.2*3
+1 IF '$GET(DFN)
QUIT -1
+2 IF '$DATA(^DPT(DFN,0))
QUIT -1
+3 IF $$DOB^AUPNPAT(DFN)<0
QUIT -1
+4 IF $GET(D)=""
SET D=DT
+5 IF $GET(F)=""
SET F="Y"
+6 NEW %
+7 SET %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN))
+8 IF F="Y"
QUIT %\365.25
+9 ;beginning Y2K
+10 ;NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
+11 ;Y2000
NEW %1
SET %1=%\365.25
SET %=$SELECT(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")
+12 ;end Y2000
+13 QUIT %
+14 ;
+15 ;
IMMBI ;IHS/CMI/LAB - new subroutine for new imm package
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 ;
+3 ;
+4 ;
+5 NEW APCH31,APCHIMM,APCHBIER
+6 SET APCH31=$CHAR(31)_$CHAR(31)
SET APCHIMM=""
+7 DO IMMFORC^BIRPC(.APCHIMM,BHSPAT)
+8 ;
+9 WRITE ?3,"IMMUNIZATION FORECAST:",!!
+10 ;
+11 Begin DoDot:1
+12 ;---> Check for error in 2nd piece of return value.
+13 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+14 ;---> If there's an error, display it and quit.
+15 IF APCHBIER]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
Begin DoDot:2
+16 DO EN^DDIOL("* "_APCHBIER,"","?5")
WRITE !
End DoDot:2
QUIT
+17 ;
+18 ;---> No error, so take 1st piece of return value and process it.
+19 SET APCHIMM=$PIECE(APCHIMM,APCH31,1)
+20 ;
+21 NEW APCHX,APCHI
FOR APCHX=1:1
SET APCHI=$PIECE(APCHIMM,"^",APCHX)
IF APCHI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+22 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+23 WRITE ?3,$PIECE(APCHI,"|"),?23,$PIECE(APCHI,"|",2),?36,$PIECE(APCHI,"|",3),!
+24 QUIT
End DoDot:2
End DoDot:1
+25 ;
CONTRAS ;
+1 ;
+2 NEW APCHCONT
SET APCHCONT=""
+3 ;
+4 ;---> RPC to retrieve Contraindications.
+5 DO CONTRAS^BIRPC5(.APCHCONT,BHSPAT)
+6 ;
+7 ;---> If APCHBIER has a value, display it and quit.
+8 SET APCHBIER=$PIECE(APCHCONT,APCH31,2)
+9 IF APCHBIER]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
DO EN^DDIOL("* "_APCHBIER,"","!!?5")
GOTO HX
+10 ;
+11 ;---> Set APCHC=to a string of Contraindications for this patient.
+12 NEW APCHC
SET APCHC=$PIECE(APCHCONT,APCH31,1)
+13 IF APCHC]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
+14 ;
+15 ;---> Build Listmanager array from APCHC string.
+16 ;
+17 FOR I=1:1
SET Y=$PIECE(APCHC,U,I)
IF Y=""
QUIT
Begin DoDot:1
+18 ;---> Build display line for this Contraindication.
+19 NEW V
SET V="|"
SET X=" "
+20 IF I=1
SET X=X_"* Contraindications:"
SET X=$$PAD(X,28)
+21 ;
+22 ;---> Display "Vaccine: Date Reason"
+23 SET X=X_$PIECE(Y,V,2)_":"
SET X=$$PAD(X,40)_$PIECE(Y,V,4)
+24 SET X=$$PAD(X,53)_$PIECE(Y,V,3)
+25 ;---> Set formatted Contraindication line and index in ^TMP.
+26 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE X,!
+27 QUIT
End DoDot:1
+28 ;
+29 ;
+30 ;
HX ;
+1 NEW APCHBIDE,I
FOR I=8,26,27,60,33,44,57
SET APCHBIDE(I)=""
+2 ;call to get imm hx
+3 DO IMMHX^BIRPC(.APCHIMM,BHSPAT,.APCHBIDE)
+4 WRITE !?3,"IMMUNIZATION HISTORY:",!
+5 ;
+6 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+7 IF APCHBIER]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
DO EN^DDIOL("* "_APCHBIER,"","!!?5")
QUIT
+8 SET APCHIMM=$PIECE(APCHIMM,APCH31,1)
+9 NEW APCHI,APCHV,APCHX,APCHY,APCHZ
+10 SET APCHZ=""
SET APCHV="|"
+11 FOR APCHI=1:1
SET APCHY=$PIECE(APCHIMM,U,APCHI)
IF APCHY=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+12 IF $PIECE(APCHY,APCHV)'="I"
QUIT
+13 IF $PIECE(APCHY,APCHV,4)'=APCHZ
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
SET APCHZ=$PIECE(APCHY,APCHV,4)
+14 NEW X,BHSDG
KILL %DT
SET X=$PIECE(APCHY,APCHV,8)
SET %DT="P"
DO ^%DT
SET BHSDG=Y
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+16 WRITE ?3,$PIECE(APCHY,APCHV,2),?22,$PIECE(APCHY,APCHV,8),?34,$$AGE(BHSPAT,BHSDG,"P"),?45,$EXTRACT($PIECE(APCHY,APCHV,3),1,20),?66,$PIECE(APCHY,APCHV,5),!
+17 IF $PIECE(APCHY,APCHV,6)]""
WRITE ?22,"Reaction: ",$PIECE(APCHY,APCHV,6),!
+18 QUIT
End DoDot:1
+19 ;----------
+20 KILL APCHIMM,APCHY,APCHV,APCHBIDE,APCHZ
+21 QUIT
+22 ;
+23 ;
+24 ;----------
PAD(D,L,C) ;EP
+1 ;---> Pad the length of data to a total of L characters
+2 ;---> by adding spaces to the end of the data.
+3 ; Example: S X=$$PAD("MIKE",7) X="MIKE " (Added 3 spaces.)
+4 ;---> Parameters:
+5 ; 1 - D (req) Data to be padded.
+6 ; 2 - L (req) Total length of resulting data.
+7 ; 3 - C (opt) Character to pad with (default=space).
+8 ;
+9 IF '$DATA(D)
QUIT ""
+10 IF '$GET(L)
SET L=$LENGTH(D)
+11 IF $GET(C)=""
SET C=" "
+12 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(C,L),1,L)
+13 ;
+14 ;
+15 ;----------
IMMBI2 ;EP
+1 ;---> Call to Immunization Package v8.x to build local array of formatted
+2 ;---> lines for Imm Health Summary Component. ;IHS/CMI/MWR 8/19/03
+3 ;---> Mike Remillard
+4 ;
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
DO CKP^GMTSUP
+6 NEW BHSARR
SET BHSARR=""
+7 DO IMMBI^BIAPCHS(BHSPAT,.BHSARR)
+8 ;IHS/MSC/MGH
+9 ;Changes for APCH patch 14 included in patch 1
+10 NEW N,F
+11 SET N=0
SET F=0
+12 FOR
SET N=$ORDER(^BHSARR(N))
IF 'N
QUIT
Begin DoDot:1
+13 IF BHSARR(N,0)["IMMUNIZATION HISTORY
QUIT
+14 ;varicella forecast as due
IF BHSARR(N,0)["VARICALLA"
SET F=1
+15 QUIT
End DoDot:1
+16 SET N=0
+17 FOR
SET N=$ORDER(BHSARR(N))
IF 'N
QUIT
Begin DoDot:1
+18 IF BHSARR(N,0)["IMMUNIZATION HISTORY"
Begin DoDot:2
+19 IF F
SET X=$$PHCP(BHSPAT)
IF X]""
Begin DoDot:3
+20 WRITE !,"Patient has a HX of chicken pox not yet entered as a contraindication"
+21 WRITE !,"in the Immunization Package."
+22 WRITE !,X,!!
End DoDot:3
End DoDot:2
+23 WRITE BHSARR(N,0),!
End DoDot:1
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+24 DO KILLALL^BIUTL8()
+25 QUIT
PHCP(P) ;EP
+1 ;is there a personal history of chicken pox or is chicken pox on the problem list
+2 NEW X,Y,Z,I,G
+3 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNPH("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPH(X,0))
QUIT
+5 SET I=$PIECE(^AUPNPH(X,0),U)
+6 IF I=""
QUIT
+7 ;S I=$P($G(^ICD9(I,0)),U)
+8 ;Patch 9 for ICD-10
+9 IF $$AICD^BHSUTL
SET I=$PIECE($$ICDDX^ICDEX(I,"","","I"),U,2)
+10 ;code set versioning
IF '$TEST
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+11 IF $EXTRACT(I,1,3)'="052"
QUIT
+12 SET G=X
+13 QUIT
End DoDot:1
+14 IF G
QUIT "Personal History: "_I_" - "_$$VAL^XBDIQ1(9000013,G,.04)
+15 ;now check problem list
+16 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+17 IF '$DATA(^AUPNPROB(X,0))
QUIT
+18 SET I=$PIECE(^AUPNPROB(X,0),U)
+19 IF I=""
QUIT
+20 ;S I=$P($G(^ICD9(I,0)),U)
+21 ;Patch 9 for ICD-10
+22 IF $$AICD^BHSUTL
SET I=$PIECE($$ICDDX^ICDEX(I,"","","I"),U,2)
+23 ;code set versioning
IF '$TEST
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+24 IF $EXTRACT(I,1,3)'="052"
QUIT
+25 SET G=X
+26 QUIT
End DoDot:1
+27 IF G
QUIT "Problem List: "_I_" - "_$$VAL^XBDIQ1(9000011,G,.05)
+28 QUIT ""
