APCDLIM ; IHS/CMI/LAB - LIST IMMUNIZATION DATA ;
;;2.0;IHS PCC SUITE;**2,7,8**;MAY 14, 2009;Build 2
;
W !?10,"Immunization Record",!
S APCDLIM("IMM")="" F S APCDLIM("IMM")=$O(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"))) Q:APCDLIM("IMM")="" D IMM
K APCDLIM
Q
;
IMM ;
S APCDLIM("IMM NAME")=$P(^AUTTIMM(APCDLIM("IMM"),0),U,2),APCDLIM("IMM NAME LNTH")=$L(APCDLIM("IMM NAME")) W !,APCDLIM("IMM NAME") D DATE
Q
;
DATE ;
S APCDLIM("DATE")="" F S APCDLIM("DATE")=$O(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"),APCDLIM("DATE"))) Q:APCDLIM("DATE")="" D DISP
Q
;
DISP ;
S APCDLIM("DFN")=0 F S APCDLIM("DFN")=$O(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"),APCDLIM("DATE"),APCDLIM("DFN"))) Q:APCDLIM("DFN")="" D DISP2
Q
;
DISP2 ;
S Y=-APCDLIM("DATE")\1+9999999 S:Y]"" Y=+Y,Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3)) S APCDLIM("PRINT DATE")=Y K Y
S APCDLIM("VISIT")=$P(^AUPNVIMM(APCDLIM("DFN"),0),U,3) D GETSITE
W ?(APCDLIM("IMM NAME LNTH")+4),$P(^AUPNVIMM(APCDLIM("DFN"),0),U,4),?17,APCDLIM("PRINT DATE")," ",APCDLIM("SITE"),!
Q
;
GETSITE ;
S APCDLIM("SITE")=$P(^AUPNVSIT(APCDLIM("VISIT"),0),U,6)
S APCDLIM("SITE")=$P($G(^DIC(4,APCDLIM("SITE"),0)),U)
I $P($G(^AUPNVSIT(APCDLIM("VISIT"),21)),U,1)]"" S APCDLIM("SITE")=$P(^(21),U)
S:APCDLIM("SITE")="" APCDLIM("SITE")="<null>"
Q
;
HSIMM ;EP - called from xbnew
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
I $$BI^APCHS11C D IMMBI Q ;IHS/CMI/LAB - new imm package
; <SETUP>
Q:'$D(^AUPNVIMM("AA",APCDTP))
; <DISPLAY>
NEW APCDSITP,APCDSQ,APCDSITX,APCDSITL,APCDSIVD,APCDSDFN,APCDSN,APCHSVDF,APCDSITE,APCHSNSH,APCDSIR,APCDSP,APCDSIR,APCDSIC
S APCDSITP="" F APCDSQ=0:0 S APCDSITP=$O(^AUPNVIMM("AA",APCDTP,APCDSITP)) Q:APCDSITP="" D IMMDTYP
; <CLEANUP>
K APCHSITE,APCHSNAB,APCHSNFL,APCHSNSH,APCHSP,APCHSVDF,APCHSVSC
Q
IMMDTYP S APCDSITX=$P(^AUTTIMM(APCDSITP,0),U,2),APCDSITL=$L(APCDSITX) W !,APCDSITX S APCDSIVD="" F APCDSQ=0:0 S APCDSIVD=$O(^AUPNVIMM("AA",APCDTP,APCDSITP,APCDSIVD)) Q:'APCDSIVD D IMMDSP
Q
IMMDSP S APCDSDFN=0 F APCDSQ=0:0 S APCDSDFN=$O(^AUPNVIMM("AA",APCDTP,APCDSITP,APCDSIVD,APCDSDFN)) Q:APCDSDFN="" D IMMDSP2
Q
IMMDSP2 S Y=-APCDSIVD\1+9999999 S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+($E(Y,1,3))) S APCDSDAT=Y
S APCDSN=^AUPNVIMM(APCDSDFN,0)
S APCHSVDF=$P(APCDSN,U,3) D GETSITEV^APCHSUTL S APCDSITE=APCHSNSH
S X=$P(APCDSN,U,6),Y=.06 D IMMGSET S APCDSIR=APCDSP
S X=$P(APCDSN,U,7),Y=.07 D IMMGSET S APCDSIC=APCDSP S:APCDSIC]"" APCDSIC="DO NOT REPEAT"
I APCDSIC]"",APCDSIR]"" S APCDSIR=APCDSIR_"; "
S APCDSIR=APCDSIR_APCDSIC
;modified following line - LAB
W ?(APCDSITL+1),$P(^AUPNVIMM(APCDSDFN,0),U,4),?20,APCDSDAT,?28,$$AGE(APCDTP,$P(+^AUPNVSIT(APCHSVDF,0),"."),"P"),?37,APCDSITE,?65,APCDSIR,!
Q
IMMGSET S Y=$G(^DD(9000010.11,Y,0)),Y=$P(Y,U,3)
S:'X Y=""
F APCDSQ=1:1 S APCDSP=$P(Y,";",APCDSQ) Q:APCDSP="" I $P(APCDSP,":",1)=X S APCDSP=$P(APCDSP,":",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
S APCD31=$C(31)_$C(31),APCDIMM=""
HX ;
;---> Get Data Element 4 instead of 8 (no more Dose#, v8.0). ;CMI/ER/MWR 11/19/03
;NEW APCDBIDE,I F I=8,26,27,60,33,44,57 S APCDBIDE(I)=""
NEW APCDBIDE,I F I=4,26,27,60,33,44,57 S APCDBIDE(I)=""
;call to get imm hx
D IMMHX^BIRPC(.APCDIMM,APCDTP,.APCDBIDE)
W !?3,"IMMUNIZATION HISTORY:",!
;
S APCDBIER=$P(APCDIMM,APCD31,2)
I APCDBIER]"" D EN^DDIOL("* "_APCDBIER,"","!!?5") Q
S APCDIMM=$P(APCDIMM,APCD31,1)
NEW APCDI,APCDV,APCDX,APCDY,APCDZ
S APCDZ="",APCDV="|"
F APCDI=1:1 S APCDY=$P(APCDIMM,U,APCDI) Q:APCDY=""!($D(APCDSQIT)) D
.Q:$P(APCDY,APCDV)'="I"
.I $P(APCDY,APCDV,4)'=APCDZ W ! S APCDZ=$P(APCDY,APCDV,4)
.NEW X,APCDSDG K %DT S X=$P(APCDY,APCDV,8),%DT="P" D ^%DT S APCDSDG=Y
.;---> Make room for vaccine combination names (v8.0). ;CMI/ER/MWR 11/19/03
.;W ?3,$P(APCDY,APCDV,2),?22,$P(APCDY,APCDV,8),?34,$$AGE(APCDTP,APCDSDG,"P"),?45,$E($P(APCDY,APCDV,3),1,20),?66,$P(APCDY,APCDV,5),!
.W ?3,$P(APCDY,APCDV,2),?24,$P(APCDY,APCDV,8),?36,$$AGE(APCDTP,APCDSDG,"P"),?47,$E($P(APCDY,APCDV,3),1,18),?66,$P(APCDY,APCDV,5),!
.I $P(APCDY,APCDV,6)]"" W ?22,"Reaction: ",$P(APCDY,APCDV,6),!
.Q
;----------
K APCDIMM,APCDY,APCDV,APCDBIDE,APCDZ
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)
;
;
;----------
GETIMM ;EP - called from APCD IM (ADD) template
S APCDX=$$CREATE(APCDVSIT,APCDPAT)
I APCDX]"" W !!,APCDX," Immunization entry failed."
K Y,APCDX
Q
CREATE(APCDV,APCDP) ;
K DIC
S DIC="^AUTTIMM(",DIC("S")="I $P(^(0),U,7)'=1",DIC(0)="AEMQ" D ^DIC
I Y=-1 Q "No immunization type selected."
K DIC
S DIC="^AUPNVIMM(",X=+Y,DIC(0)="L",DIADD=1,DLAYGO=9000010.11,DIC("DR")=".02////"_APCDP_";.03////"_APCDV
D FILE^DICN K DIADD,DLAYGO,DIC,DR
I Y=-1 Q "error creating V Immunization entry"
S DA=+Y,DIE="^AUPNVIMM(",DR=".05;.14;1204;1216////"_$$NOW^XLFDT D ^DIE
Q ""
APCDLIM ; IHS/CMI/LAB - LIST IMMUNIZATION DATA ;
+1 ;;2.0;IHS PCC SUITE;**2,7,8**;MAY 14, 2009;Build 2
+2 ;
+3 WRITE !?10,"Immunization Record",!
+4 SET APCDLIM("IMM")=""
FOR
SET APCDLIM("IMM")=$ORDER(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM")))
IF APCDLIM("IMM")=""
QUIT
DO IMM
+5 KILL APCDLIM
+6 QUIT
+7 ;
IMM ;
+1 SET APCDLIM("IMM NAME")=$PIECE(^AUTTIMM(APCDLIM("IMM"),0),U,2)
SET APCDLIM("IMM NAME LNTH")=$LENGTH(APCDLIM("IMM NAME"))
WRITE !,APCDLIM("IMM NAME")
DO DATE
+2 QUIT
+3 ;
DATE ;
+1 SET APCDLIM("DATE")=""
FOR
SET APCDLIM("DATE")=$ORDER(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"),APCDLIM("DATE")))
IF APCDLIM("DATE")=""
QUIT
DO DISP
+2 QUIT
+3 ;
DISP ;
+1 SET APCDLIM("DFN")=0
FOR
SET APCDLIM("DFN")=$ORDER(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"),APCDLIM("DATE"),APCDLIM("DFN")))
IF APCDLIM("DFN")=""
QUIT
DO DISP2
+2 QUIT
+3 ;
DISP2 ;
+1 SET Y=-APCDLIM("DATE")\1+9999999
IF Y]""
SET Y=+Y
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
SET APCDLIM("PRINT DATE")=Y
KILL Y
+2 SET APCDLIM("VISIT")=$PIECE(^AUPNVIMM(APCDLIM("DFN"),0),U,3)
DO GETSITE
+3 WRITE ?(APCDLIM("IMM NAME LNTH")+4),$PIECE(^AUPNVIMM(APCDLIM("DFN"),0),U,4),?17,APCDLIM("PRINT DATE")," ",APCDLIM("SITE"),!
+4 QUIT
+5 ;
GETSITE ;
+1 SET APCDLIM("SITE")=$PIECE(^AUPNVSIT(APCDLIM("VISIT"),0),U,6)
+2 SET APCDLIM("SITE")=$PIECE($GET(^DIC(4,APCDLIM("SITE"),0)),U)
+3 IF $PIECE($GET(^AUPNVSIT(APCDLIM("VISIT"),21)),U,1)]""
SET APCDLIM("SITE")=$PIECE(^(21),U)
+4 IF APCDLIM("SITE")=""
SET APCDLIM("SITE")="<null>"
+5 QUIT
+6 ;
HSIMM ;EP - called from xbnew
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
+1 ;IHS/CMI/LAB - new imm package
IF $$BI^APCHS11C
DO IMMBI
QUIT
+2 ; <SETUP>
+3 IF '$DATA(^AUPNVIMM("AA",APCDTP))
QUIT
+4 ; <DISPLAY>
+5 NEW APCDSITP,APCDSQ,APCDSITX,APCDSITL,APCDSIVD,APCDSDFN,APCDSN,APCHSVDF,APCDSITE,APCHSNSH,APCDSIR,APCDSP,APCDSIR,APCDSIC
+6 SET APCDSITP=""
FOR APCDSQ=0:0
SET APCDSITP=$ORDER(^AUPNVIMM("AA",APCDTP,APCDSITP))
IF APCDSITP=""
QUIT
DO IMMDTYP
+7 ; <CLEANUP>
+8 KILL APCHSITE,APCHSNAB,APCHSNFL,APCHSNSH,APCHSP,APCHSVDF,APCHSVSC
+9 QUIT
IMMDTYP SET APCDSITX=$PIECE(^AUTTIMM(APCDSITP,0),U,2)
SET APCDSITL=$LENGTH(APCDSITX)
WRITE !,APCDSITX
SET APCDSIVD=""
FOR APCDSQ=0:0
SET APCDSIVD=$ORDER(^AUPNVIMM("AA",APCDTP,APCDSITP,APCDSIVD))
IF 'APCDSIVD
QUIT
DO IMMDSP
+1 QUIT
IMMDSP SET APCDSDFN=0
FOR APCDSQ=0:0
SET APCDSDFN=$ORDER(^AUPNVIMM("AA",APCDTP,APCDSITP,APCDSIVD,APCDSDFN))
IF APCDSDFN=""
QUIT
DO IMMDSP2
+1 QUIT
IMMDSP2 SET Y=-APCDSIVD\1+9999999
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+($EXTRACT(Y,1,3)))
SET APCDSDAT=Y
+1 SET APCDSN=^AUPNVIMM(APCDSDFN,0)
+2 SET APCHSVDF=$PIECE(APCDSN,U,3)
DO GETSITEV^APCHSUTL
SET APCDSITE=APCHSNSH
+3 SET X=$PIECE(APCDSN,U,6)
SET Y=.06
DO IMMGSET
SET APCDSIR=APCDSP
+4 SET X=$PIECE(APCDSN,U,7)
SET Y=.07
DO IMMGSET
SET APCDSIC=APCDSP
IF APCDSIC]""
SET APCDSIC="DO NOT REPEAT"
+5 IF APCDSIC]""
IF APCDSIR]""
SET APCDSIR=APCDSIR_"; "
+6 SET APCDSIR=APCDSIR_APCDSIC
+7 ;modified following line - LAB
+8 WRITE ?(APCDSITL+1),$PIECE(^AUPNVIMM(APCDSDFN,0),U,4),?20,APCDSDAT,?28,$$AGE(APCDTP,$PIECE(+^AUPNVSIT(APCHSVDF,0),"."),"P"),?37,APCDSITE,?65,APCDSIR,!
+9 QUIT
IMMGSET SET Y=$GET(^DD(9000010.11,Y,0))
SET Y=$PIECE(Y,U,3)
+1 IF 'X
SET Y=""
+2 FOR APCDSQ=1:1
SET APCDSP=$PIECE(Y,";",APCDSQ)
IF APCDSP=""
QUIT
IF $PIECE(APCDSP,":",1)=X
SET APCDSP=$PIECE(APCDSP,":",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 SET APCD31=$CHAR(31)_$CHAR(31)
SET APCDIMM=""
HX ;
+1 ;---> Get Data Element 4 instead of 8 (no more Dose#, v8.0). ;CMI/ER/MWR 11/19/03
+2 ;NEW APCDBIDE,I F I=8,26,27,60,33,44,57 S APCDBIDE(I)=""
+3 NEW APCDBIDE,I
FOR I=4,26,27,60,33,44,57
SET APCDBIDE(I)=""
+4 ;call to get imm hx
+5 DO IMMHX^BIRPC(.APCDIMM,APCDTP,.APCDBIDE)
+6 WRITE !?3,"IMMUNIZATION HISTORY:",!
+7 ;
+8 SET APCDBIER=$PIECE(APCDIMM,APCD31,2)
+9 IF APCDBIER]""
DO EN^DDIOL("* "_APCDBIER,"","!!?5")
QUIT
+10 SET APCDIMM=$PIECE(APCDIMM,APCD31,1)
+11 NEW APCDI,APCDV,APCDX,APCDY,APCDZ
+12 SET APCDZ=""
SET APCDV="|"
+13 FOR APCDI=1:1
SET APCDY=$PIECE(APCDIMM,U,APCDI)
IF APCDY=""!($DATA(APCDSQIT))
QUIT
Begin DoDot:1
+14 IF $PIECE(APCDY,APCDV)'="I"
QUIT
+15 IF $PIECE(APCDY,APCDV,4)'=APCDZ
WRITE !
SET APCDZ=$PIECE(APCDY,APCDV,4)
+16 NEW X,APCDSDG
KILL %DT
SET X=$PIECE(APCDY,APCDV,8)
SET %DT="P"
DO ^%DT
SET APCDSDG=Y
+17 ;---> Make room for vaccine combination names (v8.0). ;CMI/ER/MWR 11/19/03
+18 ;W ?3,$P(APCDY,APCDV,2),?22,$P(APCDY,APCDV,8),?34,$$AGE(APCDTP,APCDSDG,"P"),?45,$E($P(APCDY,APCDV,3),1,20),?66,$P(APCDY,APCDV,5),!
+19 WRITE ?3,$PIECE(APCDY,APCDV,2),?24,$PIECE(APCDY,APCDV,8),?36,$$AGE(APCDTP,APCDSDG,"P"),?47,$EXTRACT($PIECE(APCDY,APCDV,3),1,18),?66,$PIECE(APCDY,APCDV,5),!
+20 IF $PIECE(APCDY,APCDV,6)]""
WRITE ?22,"Reaction: ",$PIECE(APCDY,APCDV,6),!
+21 QUIT
End DoDot:1
+22 ;----------
+23 KILL APCDIMM,APCDY,APCDV,APCDBIDE,APCDZ
+24 QUIT
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 ;----------
GETIMM ;EP - called from APCD IM (ADD) template
+1 SET APCDX=$$CREATE(APCDVSIT,APCDPAT)
+2 IF APCDX]""
WRITE !!,APCDX," Immunization entry failed."
+3 KILL Y,APCDX
+4 QUIT
CREATE(APCDV,APCDP) ;
+1 KILL DIC
+2 SET DIC="^AUTTIMM("
SET DIC("S")="I $P(^(0),U,7)'=1"
SET DIC(0)="AEMQ"
DO ^DIC
+3 IF Y=-1
QUIT "No immunization type selected."
+4 KILL DIC
+5 SET DIC="^AUPNVIMM("
SET X=+Y
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9000010.11
SET DIC("DR")=".02////"_APCDP_";.03////"_APCDV
+6 DO FILE^DICN
KILL DIADD,DLAYGO,DIC,DR
+7 IF Y=-1
QUIT "error creating V Immunization entry"
+8 SET DA=+Y
SET DIE="^AUPNVIMM("
SET DR=".05;.14;1204;1216////"_$$NOW^XLFDT
DO ^DIE
+9 QUIT ""
