BSDX41H ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
; <SETUP>
Q:'$D(^AUPNVMSR("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
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="" D
. ;X APCHSCKP Q:$D(APCHSQIT)
. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
Q
MEASDSP S APCHSDFN=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,"")),Y=-APCHSIVD\1+9999999
X APCHSCVD
S APCHSDAT=Y
;X APCHSCKP Q:$D(APCHSQIT)
S:APCHSNPG!(APCHSMT3]"") BSDXTMP=APCHSMT2
S APCHSMT3=""
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(5-$L(BSDXTMP))_APCHSDAT
S BSDXTMP=BSDXTMP_$$FILL^BSDX541(18-$L(BSDXTMP))_$P(^AUPNVMSR(APCHSDFN,0),U,4)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
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)
..S BSDXTMP=$$VAL^XBDIQ1(9002084.11,APCHX,.02)_" -- "_$$VAL^XBDIQ1(9002084.11,APCHX,.03)
..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_"("_$$DATE^APCHSMU($P(^BIPC(APCHX,0),U,4))_")"
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
..Q
.Q
S APCHSFN=9999999.14,APCHST="" D DISPREF^BSDX41F
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)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXTMP=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)
S:APCHSNPG BSDXTMP=APCHSITX
S BSDXTMP=BSDXTMP_$$FILL^BSDX41((APCHSITL+1)-$L(BSDXTMP))_$P(^AUPNVIMM(APCHSDFN,0),U,4)
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(15-$L(BSDXTMP))_APCHSDAT
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(25-$L(BSDXTMP))_$$AGE(APCHSPAT,$P(+^AUPNVSIT(APCHSVDF,0),"."),"P")
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_APCHSITE
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(65-$L(BSDXTMP))_APCHSIR
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
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)
;
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" "_"IMMUNIZATION FORECAST:"_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
;
S APCH31="||"
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]"" Q
.;
.;---> 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)
..S BSDXTMP=" "_$P(APCHI,"|")
..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$L(BSDXTMP))_$P(APCHI,"|",2)
..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(36-$L(BSDXTMP))_$P(APCHI,"|",3)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
..Q
;
CONTRAS ;
;
N APCHCONT S APCHCONT=""
;
;---> RPC to retrieve Contraindications.
D CONTRAS^BIRPC5(.APCHCONT,APCHSPAT)
;
S APCH31="||"
;---> If APCHBIER has a value, display it and quit.
S APCHBIER=$P(APCHCONT,APCH31,2)
I APCHBIER]"" D
.;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]"" D
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
;
;---> 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)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=X_$C(30)
.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,,0)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" "_"IMMUNIZATION HISTORY:"_$C(30)
;
S APCH31="||"
S APCHBIER=$P(APCHIMM,APCH31,2)
I APCHBIER]"" Q ;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 D
..;X APCHSCKP Q:$D(APCHSQIT)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
..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)
.S BSDXTMP=" "_$P(APCHY,APCHV,2)
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_$P(APCHY,APCHV,8)
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_$$AGE(APCHSPAT,APCHSDG,"P")
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(45-$L(BSDXTMP))_$E($P(APCHY,APCHV,3),1,20)
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$L(BSDXTMP))_$P(APCHY,APCHV,5)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
.I $P(APCHY,APCHV,6)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(21)_"Reaction: "_$P(APCHY,APCHV,6)_$C(30)
.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
...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Patient has a Hx of chicken pox not yet entered as a contraindication"_$C(30)
...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="in the Immunization Package."_$C(30)
...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=X_$C(30)
...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSARR(N,0)_$C(30)
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) ;cmi/anch/maw 8/28/2007 orig line
.S I=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 8/28/2007 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(^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 ""
BSDX41H ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVMSR("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 ;X APCHSCKP Q:$D(APCHSQIT)
+6 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+7 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
+8 ; <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=""
Begin DoDot:1
+3 ;X APCHSCKP Q:$D(APCHSQIT)
+4 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
End DoDot:1
+5 QUIT
MEASDSP SET APCHSDFN=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,""))
SET Y=-APCHSIVD\1+9999999
+1 XECUTE APCHSCVD
+2 SET APCHSDAT=Y
+3 ;X APCHSCKP Q:$D(APCHSQIT)
+4 IF APCHSNPG!(APCHSMT3]"")
SET BSDXTMP=APCHSMT2
+5 SET APCHSMT3=""
+6 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(5-$LENGTH(BSDXTMP))_APCHSDAT
+7 SET BSDXTMP=BSDXTMP_$$FILL^BSDX541(18-$LENGTH(BSDXTMP))_$PIECE(^AUPNVMSR(APCHSDFN,0),U,4)
+8 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+9 QUIT
+10 ;
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 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG 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 ;X APCHSCKP Q:$D(APCHSQIT)
+12 SET BSDXTMP=$$VAL^XBDIQ1(9002084.11,APCHX,.02)_" -- "_$$VAL^XBDIQ1(9002084.11,APCHX,.03)
+13 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$LENGTH(BSDXTMP))_"("_$$DATE^APCHSMU($PIECE(^BIPC(APCHX,0),U,4))_")"
+14 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 SET APCHSFN=9999999.14
SET APCHST=""
DO DISPREF^BSDX41F
+18 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)
+1 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 SET BSDXTMP=APCHSITX
SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD))
IF 'APCHSIVD
QUIT
DO IMMDSP
+4 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 ;X APCHSCKP Q:$D(APCHSQIT)
+9 IF APCHSNPG
SET BSDXTMP=APCHSITX
+10 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41((APCHSITL+1)-$LENGTH(BSDXTMP))_$PIECE(^AUPNVIMM(APCHSDFN,0),U,4)
+11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(15-$LENGTH(BSDXTMP))_APCHSDAT
+12 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(25-$LENGTH(BSDXTMP))_$$AGE(APCHSPAT,$PIECE(+^AUPNVSIT(APCHSVDF,0),"."),"P")
+13 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$LENGTH(BSDXTMP))_APCHSITE
+14 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(65-$LENGTH(BSDXTMP))_APCHSIR
+15 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+16 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 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" "_"IMMUNIZATION FORECAST:"_$CHAR(30)
+10 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+11 ;
+12 SET APCH31="||"
+13 Begin DoDot:1
+14 ;---> Check for error in 2nd piece of return value.
+15 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+16 ;---> If there's an error, display it and quit.
+17 IF APCHBIER]""
QUIT
+18 ;
+19 ;---> No error, so take 1st piece of return value and process it.
+20 SET APCHIMM=$PIECE(APCHIMM,APCH31,1)
+21 ;
+22 NEW APCHX,APCHI
FOR APCHX=1:1
SET APCHI=$PIECE(APCHIMM,"^",APCHX)
IF APCHI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+23 ;X APCHSCKP Q:$D(APCHSQIT)
+24 SET BSDXTMP=" "_$PIECE(APCHI,"|")
+25 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$LENGTH(BSDXTMP))_$PIECE(APCHI,"|",2)
+26 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(36-$LENGTH(BSDXTMP))_$PIECE(APCHI,"|",3)
+27 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+28 QUIT
End DoDot:2
End DoDot:1
+29 ;
CONTRAS ;
+1 ;
+2 NEW APCHCONT
SET APCHCONT=""
+3 ;
+4 ;---> RPC to retrieve Contraindications.
+5 DO CONTRAS^BIRPC5(.APCHCONT,APCHSPAT)
+6 ;
+7 SET APCH31="||"
+8 ;---> If APCHBIER has a value, display it and quit.
+9 SET APCHBIER=$PIECE(APCHCONT,APCH31,2)
+10 IF APCHBIER]""
Begin DoDot:1
+11 ;X APCHSCKP Q:$D(APCHSQIT)
+12 ;D EN^DDIOL("* "_APCHBIER,"","!!?5")
+13 GOTO HX
End DoDot:1
+14 ;
+15 ;---> Set APCHC=to a string of Contraindications for this patient.
+16 NEW APCHC
SET APCHC=$PIECE(APCHCONT,APCH31,1)
+17 IF APCHC]""
Begin DoDot:1
+18 ;X APCHSCKP Q:$D(APCHSQIT)
+19 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
End DoDot:1
+20 ;
+21 ;---> Build Listmanager array from APCHC string.
+22 ;
+23 FOR I=1:1
SET Y=$PIECE(APCHC,U,I)
IF Y=""
QUIT
Begin DoDot:1
+24 ;---> Build display line for this Contraindication.
+25 NEW V
SET V="|"
SET X=" "
+26 IF I=1
SET X=X_"* Contraindications:"
SET X=$$PAD(X,28)
+27 ;
+28 ;---> Display "Vaccine: Date Reason"
+29 SET X=X_$PIECE(Y,V,2)_":"
SET X=$$PAD(X,40)_$PIECE(Y,V,4)
+30 SET X=$$PAD(X,53)_$PIECE(Y,V,3)
+31 ;---> Set formatted Contraindication line and index in ^TMP.
+32 ;X APCHSCKP Q:$D(APCHSQIT)
+33 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=X_$CHAR(30)
+34 QUIT
End DoDot:1
+35 ;
+36 ;
+37 ;
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,,0)
+4 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+5 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" "_"IMMUNIZATION HISTORY:"_$CHAR(30)
+6 ;
+7 SET APCH31="||"
+8 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+9 ;X APCHSCKP Q:$D(APCHSQIT) D EN^DDIOL("* "_APCHBIER,"","!!?5") Q
IF APCHBIER]""
QUIT
+10 SET APCHIMM=$PIECE(APCHIMM,APCH31,1)
+11 NEW APCHI,APCHV,APCHX,APCHY,APCHZ
+12 SET APCHZ=""
SET APCHV="|"
+13 FOR APCHI=1:1
SET APCHY=$PIECE(APCHIMM,U,APCHI)
IF APCHY=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+14 IF $PIECE(APCHY,APCHV)'="I"
QUIT
+15 IF $PIECE(APCHY,APCHV,4)'=APCHZ
Begin DoDot:2
+16 ;X APCHSCKP Q:$D(APCHSQIT)
+17 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+18 SET APCHZ=$PIECE(APCHY,APCHV,4)
End DoDot:2
+19 NEW X,APCHSDG
KILL %DT
SET X=$PIECE(APCHY,APCHV,8)
SET %DT="P"
DO ^%DT
SET APCHSDG=Y
+20 ;X APCHSCKP Q:$D(APCHSQIT)
+21 SET BSDXTMP=" "_$PIECE(APCHY,APCHV,2)
+22 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_$PIECE(APCHY,APCHV,8)
+23 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$LENGTH(BSDXTMP))_$$AGE(APCHSPAT,APCHSDG,"P")
+24 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(45-$LENGTH(BSDXTMP))_$EXTRACT($PIECE(APCHY,APCHV,3),1,20)
+25 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$LENGTH(BSDXTMP))_$PIECE(APCHY,APCHV,5)
+26 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+27 IF $PIECE(APCHY,APCHV,6)]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(21)_"Reaction: "_$PIECE(APCHY,APCHV,6)_$CHAR(30)
+28 QUIT
End DoDot:1
+29 ;----------
+30 KILL APCHIMM,APCHY,APCHV,APCHBIDE,APCHZ
+31 QUIT
+32 ;
+33 ;
+34 ;----------
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 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG 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 ;X APCHSCKP Q:$D(APCHSQIT)
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 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+19 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="Patient has a Hx of chicken pox not yet entered as a contraindication"_$CHAR(30)
+20 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="in the Immunization Package."_$CHAR(30)
+21 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=X_$CHAR(30)
+22 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
End DoDot:3
End DoDot:2
+23 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSARR(N,0)_$CHAR(30)
End DoDot:1
+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) ;cmi/anch/maw 8/28/2007 orig line
+8 ;cmi/anch/maw 8/28/2007 code set versioning
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+9 IF $EXTRACT(I,1,3)'="052"
QUIT
+10 SET G=X
+11 QUIT
End DoDot:1
+12 IF G
QUIT "Personal History: "_I_" - "_$$VAL^XBDIQ1(9000013,G,.04)
+13 ;now check problem list
+14 SET X=0
FOR
SET X=$ORDER(^AUPNPH("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+15 IF '$DATA(^AUPNPH(X,0))
QUIT
+16 SET I=$PIECE(^AUPNPH(X,0),U)
+17 IF I=""
QUIT
+18 SET I=$PIECE($GET(^ICD9(I,0)),U)
+19 IF $EXTRACT(I,1,3)'="052"
QUIT
+20 SET G=X
+21 QUIT
End DoDot:1
+22 IF G
QUIT "Problem List: "_I_" - "_$$VAL^XBDIQ1(9000011,G,.05)
+23 QUIT ""
