APCHS2 ; IHS/CMI/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**4,9,10,11,20**;MAY 14, 2009;Build 25
;IHS/CMI/LAB - patch 2 fixed AGE subroutine
;IHS/CMI/LAB - patch 3 new imm package
;cmi/anch/maw 8/28/2007 code set versioning in PHCP
;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
; <SETUP>
Q:'$D(^AUPNVMSR("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT) W !
S APCHSMT="" F APCHSQ=0:0 S APCHSMT=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT)) Q:APCHSMT="" S APCHSND2=APCHSNDM D MEASDTYP Q:$D(APCHSQIT)
; <CLEANUP>
MEASX K APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
Q
MEASDTYP S APCHSMT2=$S($D(^AUTTMSR(APCHSMT,0)):$P(^(0),U,1),1:APCHSMT) S APCHSMT3=APCHSMT2
S (APCHSIVD,APCHSDFN)="" F S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) S APCHSND2=APCHSND2-1 Q:APCHSND2=-1 D MEASDSP
I APCHSMT3="" X APCHSCKP Q:$D(APCHSQIT) W !
Q
MEASDSP S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,APCHSDFN)) Q:APCHSDFN'=+APCHSDFN D
.Q:$P($G(^AUPNVMSR(APCHSDFN,2)),U,1) ;entered in error
.S V=$P(^AUPNVMSR(APCHSDFN,0),U,3) Q:"HI"[$P($G(^AUPNVSIT(V,0)),U,7) ;exclude inpatient
.S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y X APCHSCKP Q:$D(APCHSQIT)
.W:APCHSNPG!(APCHSMT3]"") APCHSMT2 S APCHSMT3=""
.;PER DONNA ST.CYR EMAIL 2.25.14 ROUND BMI TO 1 DECIMAL
.;S X=$P(^AUPNVMSR(APCHSDFN,0),U,4)
.S X=$$VAL^XBDIQ1(9000010.01,APCHSDFN,.04) ;OUTPUT TX
.I $$VAL^XBDIQ1(9000010.01,APCHSDFN,.01)="BMI" D
..S X=$$STRIP^XLFSTR($J(X,8,1)," ")
.W ?5,APCHSDAT,?18,X D
..I $$VAL^XBDIQ1(9000010.01,APCHSDFN,.01)="O2" D
...Q:$P(^AUPNVMSR(APCHSDFN,0),U,10)=""
...W ?40,"Supplemental O2: ",$P(^AUPNVMSR(APCHSDFN,0),U,10),!
..I '$O(^AUPNVMSR(APCHSDFN,5,0)) W ! Q ;no qualifiers
..S C=0,X=0 F S X=$O(^AUPNVMSR(APCHSDFN,5,X)) Q:X'=+X S C=C+1
..W ?40,"Qualifier"_$S(C>1:"s",1:""),":"
..S APCHSX=0,X="" F S APCHSX=$O(^AUPNVMSR(APCHSDFN,5,APCHSX)) Q:APCHSX'=+APCHSX S Y=$P($G(^AUPNVMSR(APCHSDFN,5,APCHSX,0)),U) I Y S X=X_$S(X]"":", ",1:"")_$P($G(^GMRD(120.52,Y,0)),U,1)
..K APCHWP
..D WP^APCHS82(X,23)
..S APCHX=0,C=0 F S APCHX=$O(APCHWP(APCHX)) Q:APCHX'=+APCHX!($D(APCHSQIT)) D
...X APCHSCKP Q:$D(APCHSQIT)
...S C=C+1
...I C>1 W !
...W ?52,APCHWP(APCHX)
..W !
Q
;
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
I +$$VER^BILOGO>7.1 D IMMBI2,REF Q ;IHS/CMI/MWR 8/19/03, for Immunization v8.x
I $$BI^APCHS11C D IMMBI,REF Q ;IHS/CMI/LAB - new imm package
; <SETUP>
Q:'$D(^AUPNVIMM("AA",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSITP="" F APCHSQ=0:0 S APCHSITP=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP)) Q:APCHSITP="" D IMMDTYP
; <CLEANUP>
REF ; display refusals/contraindications from imm package and from PCC
S APCHY=0 F S APCHY=$O(^BIPC("AC",APCHSPAT,APCHY)) Q:APCHY'=+APCHY D
.S APCHX=0 F S APCHX=$O(^BIPC("AC",APCHSPAT,APCHY,APCHX)) Q:APCHX'=+APCHX D
..S R=$P(^BIPC(APCHX,0),U,3)
..Q:R=""
..Q:'$D(^BICONT(R,0))
..Q:$P(^BICONT(R,0),U,1)'["Refusal"
..S D=$P(^BIPC(APCHX,0),U,4)
..Q:D=""
..S D=9999999-D
..Q:D>APCHSDLM
..X APCHSCKP Q:$D(APCHSQIT)
..W !,$$VAL^XBDIQ1(9002084.11,APCHX,.02)," -- ",$$VAL^XBDIQ1(9002084.11,APCHX,.03),?60,"(",$$DATE^APCHSMU($P(^BIPC(APCHX,0),U,4)),")"
..Q
.Q
S APCHSFN=9999999.14,APCHST="" D DISPREF^APCHS3C
K APCHSFN,APCHST,APCHSS
IMMUNX K APCHSITP,APCHSITX,APCHSITL,APCHSDFN,APCHSDAT,APCHSIVD,APCHSVDF
K APCHSIMC,APCHSIMR,APCHSN,APCHSIC,APCHSIR
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
Q
IMMDTYP S APCHSITX=$P(^AUTTIMM(APCHSITP,0),U,2),APCHSITL=$L(APCHSITX) X APCHSCKP Q:$D(APCHSQIT) W ! X APCHSCKP Q:$D(APCHSQIT) W APCHSITX S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD)) Q:'APCHSIVD D IMMDSP
Q
IMMDSP S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD,APCHSDFN)) Q:APCHSDFN="" D IMMDSP2
Q
IMMDSP2 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
S APCHSN=^AUPNVIMM(APCHSDFN,0)
S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL S APCHSITE=APCHSNSH
S X=$P(APCHSN,U,6),Y=.06 D IMMGSET S APCHSIR=APCHSP
S X=$P(APCHSN,U,7),Y=.07 D IMMGSET S APCHSIC=APCHSP S:APCHSIC]"" APCHSIC="DO NOT REPEAT"
I APCHSIC]"",APCHSIR]"" S APCHSIR=APCHSIR_"; "
S APCHSIR=APCHSIR_APCHSIC
;modified following line - LAB
X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG APCHSITX W ?(APCHSITL+1),$P(^AUPNVIMM(APCHSDFN,0),U,4),?15,APCHSDAT,?25,$$AGE(APCHSPAT,$P(+^AUPNVSIT(APCHSVDF,0),"."),"P"),?34,APCHSITE,?65,APCHSIR,!
Q
IMMGSET S Y=$G(^DD(9000010.11,Y,0)),Y=$P(Y,U,3)
S:'X Y=""
F APCHSQ=1:1 S APCHSP=$P(Y,";",APCHSQ) Q:APCHSP="" I $P(APCHSP,":",1)=X S APCHSP=$P(APCHSP,":",2) Q
Q
;
;-----------
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
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
;
;
;
NEW APCH31,APCHIMM,APCHBIER
S APCH31=$C(31)_$C(31),APCHIMM=""
D IMMFORC^BIRPC(.APCHIMM,APCHSPAT)
;
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]"" X APCHSCKP Q:$D(APCHSQIT) 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(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..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,APCHSPAT)
;
;---> If APCHBIER has a value, display it and quit.
S APCHBIER=$P(APCHCONT,APCH31,2)
I APCHBIER]"" X APCHSCKP Q:$D(APCHSQIT) 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]"" X APCHSCKP Q:$D(APCHSQIT) 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.
.X APCHSCKP Q:$D(APCHSQIT) 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,APCHSPAT,.APCHBIDE)
W !?3,"IMMUNIZATION HISTORY:",!
;
S APCHBIER=$P(APCHIMM,APCH31,2)
I APCHBIER]"" X APCHSCKP Q:$D(APCHSQIT) 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(APCHSQIT)) D
.Q:$P(APCHY,APCHV)'="I"
.I $P(APCHY,APCHV,4)'=APCHZ X APCHSCKP Q:$D(APCHSQIT) W ! S APCHZ=$P(APCHY,APCHV,4)
.NEW X,APCHSDG K %DT S X=$P(APCHY,APCHV,8),%DT="P" D ^%DT S APCHSDG=Y
.X APCHSCKP Q:$D(APCHSQIT)
.W ?3,$P(APCHY,APCHV,2),?22,$P(APCHY,APCHV,8),?34,$$AGE(APCHSPAT,APCHSDG,"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
;
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
N APCHSARR S APCHSARR=""
D IMMBI^BIAPCHS(APCHSPAT,.APCHSARR)
;first find out if VARICELLA is forecasted
N N,F S N=0,F=0
NEW F S (F,N)=0 F S N=$O(APCHSARR(N)) Q:'N D
.Q:APCHSARR(N,0)["IMMUNIZATION HISTORY:"
.I APCHSARR(N,0)["VARICELLA" S F=1 ;varicella forecast as due
.Q
S N=0
F S N=$O(APCHSARR(N)) Q:'N D X APCHSCKP Q:$D(APCHSQIT)
.I APCHSARR(N,0)["IMMUNIZATION HISTORY" D
..I F S X=$$PHCP(APCHSPAT) 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 APCHSARR(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($$ICDDX^ICDEX(I),U,2)
.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(^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)
.Q:$E(I,1,3)'="052"
.S G=X
.Q
I G Q "Problem List: "_I_" - "_$$VAL^XBDIQ1(9000011,G,.05)
Q ""
APCHS2 ; IHS/CMI/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**4,9,10,11,20**;MAY 14, 2009;Build 25
+2 ;IHS/CMI/LAB - patch 2 fixed AGE subroutine
+3 ;IHS/CMI/LAB - patch 3 new imm package
+4 ;cmi/anch/maw 8/28/2007 code set versioning in PHCP
+5 ;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVMSR("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
+6 SET APCHSMT=""
FOR APCHSQ=0:0
SET APCHSMT=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSMT))
IF APCHSMT=""
QUIT
SET APCHSND2=APCHSNDM
DO MEASDTYP
IF $DATA(APCHSQIT)
QUIT
+7 ; <CLEANUP>
MEASX KILL APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
+1 QUIT
MEASDTYP SET APCHSMT2=$SELECT($DATA(^AUTTMSR(APCHSMT,0)):$PIECE(^(0),U,1),1:APCHSMT)
SET APCHSMT3=APCHSMT2
+1 SET (APCHSIVD,APCHSDFN)=""
FOR
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
SET APCHSND2=APCHSND2-1
IF APCHSND2=-1
QUIT
DO MEASDSP
+2 IF APCHSMT3=""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
+3 QUIT
MEASDSP SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,APCHSDFN))
IF APCHSDFN'=+APCHSDFN
QUIT
Begin DoDot:1
+1 ;entered in error
IF $PIECE($GET(^AUPNVMSR(APCHSDFN,2)),U,1)
QUIT
+2 ;exclude inpatient
SET V=$PIECE(^AUPNVMSR(APCHSDFN,0),U,3)
IF "HI"[$PIECE($GET(^AUPNVSIT(V,0)),U,7)
QUIT
+3 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 IF APCHSNPG!(APCHSMT3]"")
WRITE APCHSMT2
SET APCHSMT3=""
+5 ;PER DONNA ST.CYR EMAIL 2.25.14 ROUND BMI TO 1 DECIMAL
+6 ;S X=$P(^AUPNVMSR(APCHSDFN,0),U,4)
+7 ;OUTPUT TX
SET X=$$VAL^XBDIQ1(9000010.01,APCHSDFN,.04)
+8 IF $$VAL^XBDIQ1(9000010.01,APCHSDFN,.01)="BMI"
Begin DoDot:2
+9 SET X=$$STRIP^XLFSTR($JUSTIFY(X,8,1)," ")
End DoDot:2
+10 WRITE ?5,APCHSDAT,?18,X
Begin DoDot:2
+11 IF $$VAL^XBDIQ1(9000010.01,APCHSDFN,.01)="O2"
Begin DoDot:3
+12 IF $PIECE(^AUPNVMSR(APCHSDFN,0),U,10)=""
QUIT
+13 WRITE ?40,"Supplemental O2: ",$PIECE(^AUPNVMSR(APCHSDFN,0),U,10),!
End DoDot:3
+14 ;no qualifiers
IF '$ORDER(^AUPNVMSR(APCHSDFN,5,0))
WRITE !
QUIT
+15 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVMSR(APCHSDFN,5,X))
IF X'=+X
QUIT
SET C=C+1
+16 WRITE ?40,"Qualifier"_$SELECT(C>1:"s",1:""),":"
+17 SET APCHSX=0
SET X=""
FOR
SET APCHSX=$ORDER(^AUPNVMSR(APCHSDFN,5,APCHSX))
IF APCHSX'=+APCHSX
QUIT
SET Y=$PIECE($GET(^AUPNVMSR(APCHSDFN,5,APCHSX,0)),U)
IF Y
SET X=X_$SELECT(X]"":", ",1:"")_$PIECE($GET(^GMRD(120.52,Y,0)),U,1)
+18 KILL APCHWP
+19 DO WP^APCHS82(X,23)
+20 SET APCHX=0
SET C=0
FOR
SET APCHX=$ORDER(APCHWP(APCHX))
IF APCHX'=+APCHX!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+21 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+22 SET C=C+1
+23 IF C>1
WRITE !
+24 WRITE ?52,APCHWP(APCHX)
End DoDot:3
+25 WRITE !
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
+1 ;IHS/CMI/MWR 8/19/03, for Immunization v8.x
IF +$$VER^BILOGO>7.1
DO IMMBI2
DO REF
QUIT
+2 ;IHS/CMI/LAB - new imm package
IF $$BI^APCHS11C
DO IMMBI
DO REF
QUIT
+3 ; <SETUP>
+4 IF '$DATA(^AUPNVIMM("AA",APCHSPAT))
QUIT
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 ; <DISPLAY>
+7 SET APCHSITP=""
FOR APCHSQ=0:0
SET APCHSITP=$ORDER(^AUPNVIMM("AA",APCHSPAT,APCHSITP))
IF APCHSITP=""
QUIT
DO IMMDTYP
+8 ; <CLEANUP>
REF ; display refusals/contraindications from imm package and from PCC
+1 SET APCHY=0
FOR
SET APCHY=$ORDER(^BIPC("AC",APCHSPAT,APCHY))
IF APCHY'=+APCHY
QUIT
Begin DoDot:1
+2 SET APCHX=0
FOR
SET APCHX=$ORDER(^BIPC("AC",APCHSPAT,APCHY,APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:2
+3 SET R=$PIECE(^BIPC(APCHX,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(APCHX,0),U,4)
+8 IF D=""
QUIT
+9 SET D=9999999-D
+10 IF D>APCHSDLM
QUIT
+11 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+12 WRITE !,$$VAL^XBDIQ1(9002084.11,APCHX,.02)," -- ",$$VAL^XBDIQ1(9002084.11,APCHX,.03),?60,"(",$$DATE^APCHSMU($PIECE(^BIPC(APCHX,0),U,4)),")"
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 SET APCHSFN=9999999.14
SET APCHST=""
DO DISPREF^APCHS3C
+16 KILL APCHSFN,APCHST,APCHSS
IMMUNX KILL APCHSITP,APCHSITX,APCHSITL,APCHSDFN,APCHSDAT,APCHSIVD,APCHSVDF
+1 KILL APCHSIMC,APCHSIMR,APCHSN,APCHSIC,APCHSIR
+2 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
+3 QUIT
IMMDTYP SET APCHSITX=$PIECE(^AUTTIMM(APCHSITP,0),U,2)
SET APCHSITL=$LENGTH(APCHSITX)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSITX
SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD))
IF 'APCHSIVD
QUIT
DO IMMDSP
+1 QUIT
IMMDSP SET APCHSDFN=0
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD,APCHSDFN))
IF APCHSDFN=""
QUIT
DO IMMDSP2
+1 QUIT
IMMDSP2 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+1 SET APCHSN=^AUPNVIMM(APCHSDFN,0)
+2 SET APCHSVDF=$PIECE(APCHSN,U,3)
DO GETSITEV^APCHSUTL
SET APCHSITE=APCHSNSH
+3 SET X=$PIECE(APCHSN,U,6)
SET Y=.06
DO IMMGSET
SET APCHSIR=APCHSP
+4 SET X=$PIECE(APCHSN,U,7)
SET Y=.07
DO IMMGSET
SET APCHSIC=APCHSP
IF APCHSIC]""
SET APCHSIC="DO NOT REPEAT"
+5 IF APCHSIC]""
IF APCHSIR]""
SET APCHSIR=APCHSIR_"; "
+6 SET APCHSIR=APCHSIR_APCHSIC
+7 ;modified following line - LAB
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE APCHSITX
WRITE ?(APCHSITL+1),$PIECE(^AUPNVIMM(APCHSDFN,0),U,4),?15,APCHSDAT,?25,$$AGE(APCHSPAT,$PIECE(+^AUPNVSIT(APCHSVDF,0),"."),"P"),?34,APCHSITE,?65,APCHSIR,!
+9 QUIT
IMMGSET SET Y=$GET(^DD(9000010.11,Y,0))
SET Y=$PIECE(Y,U,3)
+1 IF 'X
SET Y=""
+2 FOR APCHSQ=1:1
SET APCHSP=$PIECE(Y,";",APCHSQ)
IF APCHSP=""
QUIT
IF $PIECE(APCHSP,":",1)=X
SET APCHSP=$PIECE(APCHSP,":",2)
QUIT
+3 QUIT
+4 ;
+5 ;-----------
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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+2 ;
+3 ;
+4 ;
+5 NEW APCH31,APCHIMM,APCHBIER
+6 SET APCH31=$CHAR(31)_$CHAR(31)
SET APCHIMM=""
+7 DO IMMFORC^BIRPC(.APCHIMM,APCHSPAT)
+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]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
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(APCHSQIT))
QUIT
Begin DoDot:2
+22 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
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,APCHSPAT)
+6 ;
+7 ;---> If APCHBIER has a value, display it and quit.
+8 SET APCHBIER=$PIECE(APCHCONT,APCH31,2)
+9 IF APCHBIER]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
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]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
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,APCHSPAT,.APCHBIDE)
+4 WRITE !?3,"IMMUNIZATION HISTORY:",!
+5 ;
+6 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+7 IF APCHBIER]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
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(APCHSQIT))
QUIT
Begin DoDot:1
+12 IF $PIECE(APCHY,APCHV)'="I"
QUIT
+13 IF $PIECE(APCHY,APCHV,4)'=APCHZ
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
SET APCHZ=$PIECE(APCHY,APCHV,4)
+14 NEW X,APCHSDG
KILL %DT
SET X=$PIECE(APCHY,APCHV,8)
SET %DT="P"
DO ^%DT
SET APCHSDG=Y
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 WRITE ?3,$PIECE(APCHY,APCHV,2),?22,$PIECE(APCHY,APCHV,8),?34,$$AGE(APCHSPAT,APCHSDG,"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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 NEW APCHSARR
SET APCHSARR=""
+7 DO IMMBI^BIAPCHS(APCHSPAT,.APCHSARR)
+8 ;first find out if VARICELLA is forecasted
+9 NEW N,F
SET N=0
SET F=0
+10 NEW F
SET (F,N)=0
FOR
SET N=$ORDER(APCHSARR(N))
IF 'N
QUIT
Begin DoDot:1
+11 IF APCHSARR(N,0)["IMMUNIZATION HISTORY
QUIT
+12 ;varicella forecast as due
IF APCHSARR(N,0)["VARICELLA"
SET F=1
+13 QUIT
End DoDot:1
+14 SET N=0
+15 FOR
SET N=$ORDER(APCHSARR(N))
IF 'N
QUIT
Begin DoDot:1
+16 IF APCHSARR(N,0)["IMMUNIZATION HISTORY"
Begin DoDot:2
+17 IF F
SET X=$$PHCP(APCHSPAT)
IF X]""
Begin DoDot:3
+18 WRITE !,"Patient has a Hx of chicken pox not yet entered as a contraindication"
+19 WRITE !,"in the Immunization Package."
+20 WRITE !,X,!!
End DoDot:3
End DoDot:2
+21 WRITE APCHSARR(N,0),!
End DoDot:1
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+22 DO KILLALL^BIUTL8()
+23 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 SET I=$PIECE($$ICDDX^ICDEX(I),U,2)
+8 IF $EXTRACT(I,1,3)'="052"
QUIT
+9 SET G=X
+10 QUIT
End DoDot:1
+11 IF G
QUIT "Personal History: "_I_" - "_$$VAL^XBDIQ1(9000013,G,.04)
+12 ;now check problem list
+13 SET X=0
FOR
SET X=$ORDER(^AUPNPH("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+14 IF '$DATA(^AUPNPH(X,0))
QUIT
+15 SET I=$PIECE(^AUPNPH(X,0),U)
+16 IF I=""
QUIT
+17 SET I=$PIECE($GET(^ICD9(I,0)),U)
+18 IF $EXTRACT(I,1,3)'="052"
QUIT
+19 SET G=X
+20 QUIT
End DoDot:1
+21 IF G
QUIT "Problem List: "_I_" - "_$$VAL^XBDIQ1(9000011,G,.05)
+22 QUIT ""
