BYIMIMM5 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
;
BRIDGE ;EP;TO MONITOR HL7 BRIDGE
Q
STAT ;EP;TO DETERMINE BRIDGE STATUS
Q
CANC ;
Q
START ;
Q
HOSTCMD ;
S X="S X=$$TERMINAL^%"_"HOSTCMD(HL7CMD)"
X X
Q
END ;
K X,HL7FUNC,HL7CMD,HL7JOBN,HL7NAME,DIR
S BYIMQUIT=1
Q
RXA(BYIMDA) ;EP;TO SET THE IIS CODE FOR RXA-11.4
Q:$G(BYIMDA)=""
S BYIMDA=+^AUTTSITE(1,0)
I $P(^BYIMPARA(0),U,4)>1,'$D(^BYIMPARA(BYIMDA,0)) D
.W !!,"BYIM Parameter Sites:"
.S BYIMDA=0
.F S BYIMDA=$O(^BYIMPARA(BYIMDA)) Q:'BYIMDA D
..W !?10,$P($G(^DIC(4,BYIMDA,0)),U)
.S DIC="^BYIMPARA("
.S DIC(0)="AEMQZ"
.S DIC("A")="Which BYIM Parameter Site: "
.D ^DIC
.I 'Y S BYIMDA="" Q
.S BYIMDA=+Y
Q:'BYIMDA
I '$D(^BYIMPARA(BYIMDA,1)) F S BYIMDA=$O(^BYIMPARA(BYIMDA)) Q:'BYIMDA Q:$D(^BYIMPARA(BYIMDA,"LAST EXPORT"))
Q:'BYIMDA
N BYIMRXA,DISP,BYIMQUIT
I $O(^BYIMPARA(BYIMDA,5,0)) D RXA1 Q
W !!,"Some state Immunization Information Systems (IIS) require facilities to send"
W !,"a code to identify the facility at which the immunization was administered or"
W !,"identify the vaccine inventory location instead of the facility name."
W !!,"If you need to add state IIS assigned code(s) please enter 'Y' below."
W !,"You will be prompted to select the name of your facility and then"
W !,"enter the state assigned code."
K DIR
S DIR(0)="YO"
S DIR("A")="Add State IIS Assigned Facility Codes"
S DIR("B")="NO"
W !!
D ^DIR
K DIR
Q:'Y
RXA1 N BYIMX
S BYIMQUIT=0
F D RXAACT Q:BYIMQUIT
Q
;-----
RXAACT ;ADDITIONAL SITE ACTION
I '$O(^BYIMPARA(BYIMDA,5,0)) D RXAADD
I '$O(^BYIMPARA(BYIMDA,5,0)) S BYIMQUIT=1 Q
D RXADISP
K DIR
S DIR(0)="SO^1:Edit Codes;2:Add codes;3:Delete codes"
W !!
D ^DIR
K DIR
I 'Y S BYIMQUIT=1 Q
I Y=1 D RXAEDIT Q
I Y=2 D RXAADD Q
I Y=3 D RXADEL
Q
;-----
RXAADD ;SELECT FACILITIES FOR STATE RXA CODE
N BYIMX,BYIMY
S DIC="^DIC(4,"
S DIC(0)="AEMQZ"
;S DIC("S")="I $D(^AUTTSITE(""B"",Y))!$D(^AUTTSITE(1,19251,""B"",Y))"
S DIC("A")="Select Facility for the IIS assigned Code: "
W !
D ^DIC
I Y<1 S BYIMQUIT=1 Q
S BYIMX=+Y
S BYIMY=$P(^DIC(4,+Y,0),U)
K DIR
S DIR(0)="FO^1:50"
S DIR("A")="Enter State IIS Code assigned for **"_BYIMY_"**"
W !
D ^DIR
K DIR
I X="" S BYIMQUIT=1 Q
S BYIMY=X
S X=BYIMX
S DA(1)=$O(^BYIMPARA(0))
S DIC="^BYIMPARA("_$$DUZ^BYIMIMM()_",5,"
S DIC(0)="L"
S DIC("DR")=".02////"_BYIMY
S DINUM=X
D FILE^DICN
I Y<1 S BYIMQUIT=1 Q
Q
;------
RXADISP ;DISPLAY EXISTING IIS RXA CODES
N DISP,J,X,Y,Z
S J=0
S X=0
F S X=$O(^BYIMPARA($$DUZ^BYIMIMM(),5,X)) Q:'X S Y=$G(^(X,0)) D:Y
.S Z=$P($G(^DIC(4,X,0)),U)
.Q:Z=""
.S Z=Z_" (IEN "_X_")"
.S J=J+1
.S X(Z)=Y
S J=0
S X=""
F S X=$O(X(X)) Q:X="" D
.S J=J+1
.S $E(DISP(J),11)=J
.S $E(DISP(J),16)=X
.S $E(DISP(J),60)=$P(X(X),U,2)
.S BYIMRXA(J)=+X(X)
S BYIMJ=J
W @IOF
W !?5,"State IIS Assigned Administered-at or Vaccine Inventory Location Code"
W !!?10,"NO."
W ?15,"Facility"
W ?59,"IIS Code"
W !?10,"---",?15,"------------------------------",?59,"--------------------"
S J=0
F S J=$O(DISP(J)) Q:'J D
.W !,DISP(J)
Q
;------
RXAEDIT ;EDIT SITE
D RXASEL
Q:'$G(DA)
RXAE1 S DA(1)=BYIMDA
S DR=".02T"
S DIE="^BYIMPARA("_BYIMDA_",5,"
W !!,"Edit IIS Facility Code for: ",$P($G(^DIC(4,DA,0)),U)
D ^DIE
K DA,DR,DIE
Q
;-----
RXADEL ;DELETE SITE
D RXASEL
Q:'$G(DA)
S X=+^BYIMPARA(BYIMDA,5,DA,0)
S X=$P($G(^DIC(4,X,0)),U)
W !?10,X
K DIR
S DIR(0)="YO"
S DIR("A")="Delete export/import site: "_X
S DIR("B")="NO"
W !
D ^DIR
K DIR
Q:Y'=1
S DA(1)=BYIMDA
S DIK="^BYIMPARA("_BYIMDA_",5,"
D ^DIK
K DA,DIK
Q
;-----
RXASEL ;SELECT ADDITION SITE
I BYIMJ=1 S Y=1 D RXASEL1 Q
K DIR
S DIR(0)="NO^1:"_BYIMJ
S DIR("A")="Select Facility number"
W !!
D ^DIR
K DIR
RXASEL1 Q:'Y
Q:'$G(BYIMRXA(Y))
S DA=BYIMRXA(Y)
Q
;-----
TEST ;EP;CREATE & SEND TEST MESSAGES
;PATCH 8 CR 08626 - INCLUDE/EXCLUDE PREVIOUSLY EXPORTED
;PATCH 8 CR 08695 - INCLUDE/EXCLUDE HISTORIC IMMS
;PATCH 8 CR 08694 - EXCLUDE IMM PRIOR TO SELECTED DATE
K DIR,BYIMFILE
W @IOF
W !!?10,"Select group of patients for TEST export"
S DIR(0)="SO^1:Random group of patients;2:Select patients for test export"
S DIR("A")="Which group of patients"
S DIR("B")="Random group of patients"
W !!
D ^DIR
K DIR
Q:'Y
I Y=2 D SEL^BYIMIMM3 Q
N Y
S Y=$P($G(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,6)
S YEARS=$S('Y:19,Y=1:65,1:99)
S CHILD=$S('Y:"Children",1:"Patients")
W @IOF
W !!?10,"TEST export option"
W !!?10,"An export file will be created for"
W !?10,CHILD," ",$S(YEARS=19:"18 years of age or under.",1:"of all ages.")
W !!
K DIR
;PATCH 8 CR 08386 - CHANGE DEFAULT FROM 10 TO 1
;S DIR(0)="NO^10:1000"
S DIR(0)="NO^1:1000"
;PATCH 8 CR 08386 END
S DIR("A",1)="Enter the number of patients"
S DIR("A")="to include in the test export"
S DIR("B")="10"
D ^DIR
K DIR
Q:'Y
K BYIMTEST
S BYIMTEST=Y
D TSPEC
K DIR
S DIR(0)="YO"
S DIR("A")="Proceed with test export of "_BYIMTEST_" patients"
S DIR("B")="NO"
W !!
D ^DIR
K DIR
Q:'Y
K ^BYIMTMP($J,"BYIM EXP")
N XX,X,Y,Z,DOB,DFN,VIS,J
S J=0
S VIS=$O(^AUPNVSIT(9999999999),-1)-$R(10)
F S VIS=$O(^AUPNVIMM("AD",VIS),-1) Q:'VIS!(J>(BYIMTEST-1)) D
.;PATCH 8 CR 08694 - SELECT ONLY BEFORE START DATE WHEN START DATE SET
.N DAT
.S DAT=+$P($G(^AUPNVSIT(VIS,0)),".")
.Q:$L(DAT)'=7
.I BYIMEDAT Q:DAT<BYIMEDAT
.;PATCH 8 CR 08694 END
.;ENSURE DIRECT/ADMINISTERED - NON-HISTORIC - VISIT TYPE
.I BYIMADM=1 Q:"CTNOEDXM"[$P(^AUPNVSIT(VIS,0),U,7)
.S X=$O(^AUPNVIMM("AD",VIS,0))
.Q:'X
.S X=$G(^AUPNVIMM(X,0))
.S DFN=+$P(X,U,2)
.Q:'DFN
.Q:$G(^DPT(DFN,.35))
.Q:'$G(^AUPNPAT(DFN,0))
.Q:$D(^BYIMTMP($J,"BYIM EXP",DFN))
.I BYIMALL'=2!(BYIMADM'=2) Q:'$$NEW^BYIMIMM6(DFN,BYIMALL,BYIMADM,BYIMEDAT)
.S DOB=$P($G(^DPT(DFN,0)),U,3)
.I '$P($G(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,6) Q:DOB<(DT-180000)
.S ^BYIMTMP($J,"BYIM EXP",DFN,VIS)=""
.S J=J+1
.S JX=0
.S JY=0
.N IMM
.S IMM=0
.F S IMM=$O(^AUPNVIMM("AC",DFN,IMM)) Q:'IMM D
..S JX=JX+1
..N IVIS
..S IVIS=$P($G(^AUPNVIMM(IMM,0)),U,3)
..Q:'IVIS
S MSGCNT=BYIMTEST+1
S XX=$P($H,",",2)
D FN^BYIMIMM
N DDATE
S (DDATE,DDDATE)=$O(^BYIMPARA($$DUZ^BYIMIMM(),"LAST EXPORT",9999999999),-1)
D DEX^BYIMIMM
Q
;-----
CLEAN ;EP;CLEAN UP AFTER TEST EXPORT
N IMM
S IMM=0
F S IMM=$O(^BYIMTMP("TEST",IMM)) Q:'IMM D
.;REMOVE 'D' WHEN SET BY TEST
.K ^BYIMEXP("D",IMM),^BYIMTMP("TEST",IMM)
S IMM=0
F S IMM=$O(^BYIMTMP("TEST ALL",IMM)) Q:'IMM D
.;RESET 'D' WHEN REMOVED BY TEST
.S ^BYIMEXP("D",IMM,+$O(^BYIMTMP("TEST ALL",IMM,"")))=""
.K ^BYIMTMP("TEST ALL",IMM)
;PATCH 8 CR 08626 END
;PATCH 8 CR 08695 END
;PATCH 8 CR 08694 END
Q
;-----
TSPEC ;SELECT SPECIFICATIONS FOR TEST EXPORT
K BYIMEDAT,BYIMADM,BYIMALL
W @IOF
W !!?10,"Default TEST export criteria"
S BYIMEDAT=""
S BYIMEDAT(0)=""
S BYIMADM=1
S BYIMALL=1
D TSHOW
K DIR
S DIR(0)="LO^1:3"
S DIR("A",1)=" 1. Specify start date for immunizations to include"
S DIR("A",2)=" 2. Exclude HISTORIC immunizations"
S DIR("A",3)=" 3. Exclude PREVIOUSLY EXPORTED immunizations"
S DIR("A",4)=" "
S DIR("A")="Select all criteria you want to set"
W !!
D ^DIR
K DIR
Q:'Y
S BYIMY=Y
F J=1:1:$L(BYIMY,",")-1 S SR="T"_$P(BYIMY,",",J) D @SR
Q:'BYIMEDAT&'BYIMADM&'BYIMALL
D TSHOW
Q
TSHOW ;SHOW TEST EXPORT CRITERIA
W !!!?10,"TEST Export Criteria:"
W !!,"Start date: ",BYIMEDAT(0)
W !!
I BYIMADM=2 D I 1
.W "Administered and historic"
E W "Only administered"
W " and ",!
I BYIMALL=2 D I 1
.W "new and previously exported"
E W "never exported"
W !,"immunizations will be included in the test export."
Q
;-----
T1 ;SELECT TEST EXPORT DATE
;PATCH 8 CR 08694 - EXCLUDE IMM PRIOR TO SELECTED DATE
K DIR
S DIR(0)="DO"
S DIR("A")="Select start date for the TEST export"
W !!
D ^DIR
K DIR
Q:'X
S BYIMEDAT=Y,BYIMEDAT(0)=Y(0)
;PATCH 8 CR 08694 END
Q
;-----
T2 ;INCLUDE ONLY ADMINISTERED IMMUNIZATIONS
;PATCH 8 CR 08695 - INCLUDE/EXCLUDE HISTORIC IMMS
S BYIMADM=1
K DIR
S DIR(0)="YO"
S DIR("A")="Exclude HISTORIC immunizations"
S DIR("B")="YES"
W !
D ^DIR
K DIR
Q:X[U
S BYIMADM=1
I 'Y S BYIMADM=2 Q
S BYIMADM=1
;PATCH 8 CR 08695 - END
Q
;-----
T3 ;EXCLUDE PREVIOUSLY EXPORTED IMMUNIZATIONS
;PATCH 8 CR 08626 - INCLUDE/EXCLUDE PREVIOUSLY EXPORTED
;BYIMALL=1 EXPORT ONLY NEW, NOT YET EXPORTED IMMS
;BYIMALL=2 EXPORT NEW AND PREVIOUSLY EXPORTED IMMS
S BYIMALL=1
K DIR
S DIR(0)="YO"
S DIR("A")="Exclude PREVIOUSLY EXPORTED immunizations"
S DIR("B")="YES"
W !
D ^DIR
K DIR
Q:X[U
I 'Y S BYIMALL=2 Q
S BYIMALL=1
;PATCH 8 CR 08626 - END
Q
;-----
COMPSPEC ;EP;TO SPECIFY MESSAGE COMPONENT CONTENT
;N X,Y,Z,XX,SEG,COMP,SCOMP,VAL,BYIMQUIT
S BYIMQUIT=0
F D CS Q:BYIMQUIT
Q
;-----
CS ;REPEAT
D CDISP
I '$O(COMP(0)) S QUIT=1 Q
D CSEL
Q
;-----
CDISP ;EP;DISPLAY COMPONENTS FOR PRIMARY SITE
S SITE=$P(^DIC(4,$$DUZ^BYIMIMM(),0),U)
D CHDR(SITE)
S X=0
F S X=$O(^BYIMPARA($$DUZ^BYIMIMM(),7,X)) Q:'X S Y=^(X,0) D
.S SEG=$P(Y,U)
.S COMP=$P(Y,U,2)
.S SCOMP=$P(Y,U,3)
.Q:'COMP!'SCOMP
.S VAL=$P(Y,U,4)_U_X
.S:SEG="MSH" SEG="1-MSH"
.S:SEG="PID" SEG="2-PID"
.S:SEG="PD1" SEG="3-PD1"
.S:SEG="NK1" SEG="4-NK1"
.S:SEG="PV1" SEG="5-PV1"
.S:SEG="ORC" SEG="6-ORC"
.S:SEG="RXA" SEG="7-RXA"
.S XX(SEG,COMP,SCOMP)=VAL
D CD
Q
;-----
CAS(AS) ;EP;DISPLAY COMPONENTS FOR ADDITIONAL EXPORT SITES
S SITE=$P(^BYIMPARA($$DUZ^BYIMIMM(),3,AS,0),U)
D CHDR(SITE)
N X,Y,Z,XX,SEG,SCOMP,VAL
S X=0
F S X=$O(^BYIMPARA($$DUZ^BYIMIMM(),3,AS,7,X)) Q:'X S Y=^(X,0) D
.S SEG=$P(Y,U)
.S COMP=$P(Y,U,2)
.S SCOMP=$P(Y,U,3)
.S VAL=$P(Y,U,4)
.S:SEG="MSH" SEG="1-MSH"
.S:SEG="PID" SEG="2-PID"
.S:SEG="PD1" SEG="3-PD1"
.S:SEG="NK1" SEG="4-NK1"
.S:SEG="PV1" SEG="5-PV1"
.S:SEG="ORC" SEG="6-ORC"
.S:SEG="RXA" SEG="7-RXA"
.S XX(SEG,COMP,SCOMP)=X_U_VAL
D CD
Q
;-----
CD ;
S JJ=0
S X=""
F S X=$O(XX(X)) Q:X="" D
.S Y=0
.F S Y=$O(XX(X,Y)) Q:'Y D
..S Z=0
..F S Z=$O(XX(X,Y,Z)) Q:'Z S VAL=XX(X,Y,Z) D
...S JJ=JJ+1
...W !,JJ,?5,$P(X,"-",2),?18,Y,?30,Z,?39,$P(VAL,U)
...S COMP(JJ)=+VAL_U_$P(X,"-",2)
S BYIMJ=JJ
Q
;
CHDR(SITE) ;DISPLAY COMPONENT HEADER
W @IOF
W !!?15,"HL7 State Specified Message Components"
W !?15,"For: ",SITE
W !!?27,"Sub-"
W !,"NO",?5,"Segment",?15,"Component",?27,"Component",?39,"Value"
W !,"--",?5,"-------",?15,"---------",?27,"---------",?39,"--------------------------"
Q
;-----
CADD ;ADD ADDITIONAL COMPONENTS
S DIR(0)="SO^1:MSH;2:PID;3:PD1;4:NK1;5:PV1;6:ORC;7:RXA"
S DIR("A")="Select a segment for component specification"
W !!
D ^DIR
K DIR
Q:'Y
S SEG=Y(0)
I $D(^BYIMPARA($$DUZ^BYIMIMM(),7,"SEG",X)) D
.S DIR(0)="YO"
.S DIR("A")="ADD another "_SEG_" component"
.W !!
.D ^DIR
Q:'Y
S X=SEG
S DA(1)=$O(^BYIMPARA(0))
S DIC="^BYIMPARA("_DA(1)_",7,"
S DIC(0)="L"
D FILE^DICN
Q:'Y
D CE(+Y,SEG)
Q
;-----
CEDIT ;EDIT COMPONENTS
K DIR
S DIR(0)="NO^1:"_BYIMJ
S DIR("A")="Select Component to edit"
W !!
D ^DIR
K DIR
Q:'Y
S SEG=$P(COMP(Y),U,2)
D CE(Y)
Q
;-----
CE(DA,SEG) S DIE="^BYIMPARA("_$$DUZ^BYIMIMM()_",7,"
S DA(1)=$O(^BYIMPARA(0))
S DA=DA
S DR=".02;.03;.04"
W !!,"Edit ",SEG," info",!
D ^DIE
Q
;-----
CDEL ;DELETE COMPONENTS
Q
;-----
CSEL ;EP;TO DISPLAY AND ADD/EDIT COMPONENTS
D CDISP
K DIR
S DIR(0)="SO^1:Edit Message Components;2:Add Message Components;3:Delete Message Components"
W !!
D ^DIR
K DIR
I 'Y S BYIMQUIT=1 Q
I Y=1 D CEDIT Q
I Y=2 D CADD Q
I Y=3 D CDEL
Q
;-----
AGECHK(UIF) ;EP;
;TO CHECK EXPORT AGE OF ADD. EXPORT SITE VERSUS EXPORT AGE OF
;PRIMARY SITE
N MSH,PID,DOB,D19
Q:'$G(UIF) 0
S MSH=$G(^INTHU(UIF,3,1,0))
Q:MSH'["MSH|" 0
S PID=$G(^INTHU(UIF,3,2,0))
Q:PID="" 0
S DOB=$P(PID,"|",8)-17000000
Q:$L(DOB)'=7 0
S D19=(DT-190000) ;CHANGE TO FM DATE FORMAT AND 19 YEARS
Q:DOB<D19 1
Q 0
;-----
ASSET(AS) ;EP;SITE STATE VARIABLES
D:AS=BYIMDUZ
.S X0=$G(^BYIMPARA(BYIMDUZ,0))
.S X1=$G(^BYIMPARA(BYIMDUZ,1))
.S X6=$G(^BYIMPARA(BYIMDUZ,6))
D:AS'=BYIMDUZ
.S X0=$G(^BYIMPARA(BYIMDUZ,3,AS,0))
.S X1=$G(^BYIMPARA(BYIMDUZ,3,AS,1))
.S X6=$G(^BYIMPARA(BYIMDUZ,3,AS,6))
S PATH=$$SLASH^BYIMIMM6($P(X0,U,2))
S (XX("MSH",3,1),XX("FHS",3,1),XX("BHS",3,1))=$P(X1,U,3)
S (XX("MSH",3,2),XX("FHS",3,2),XX("BHS",3,2))=$P(X1,U,4)
S (XX("MSH",3,3),XX("FHS",3,3),XX("BHS",3,3))=$P(X1,U,5)
S (XX("MSH",4,1),XX("FHS",4,1),XX("BHS",4,1))=$P(X0,U,7)
S (XX("MSH",4,2),XX("FHS",4,2),XX("BHS",4,2))=$P(X1,U,6)
S (XX("MSH",4,3),XX("FHS",4,3),XX("BHS",4,3))=$P(X1,U,7)
S XX("MSH",5,1)=$P(X6,U,3)
S XX("MSH",5,2)=$P(X6,U,4)
S XX("MSH",5,3)=$P(X6,U,5)
S XX("MSH",6,1)=$P(X1,U,8)
S XX("MSH",8,1)=$P(X0,U,15)
S XX("MSH",11,1)=$P(X6,U,11)
S XX("PID",11,7)=$P(X6,U,8)
S XX("PD1",3,1)=$P(X6,U)
S XX("PD1",3,2)=$P(X6,U,2)
S XX("PD1",3,3)=$P(X6,U,9)
S XX("RXA",6,1)=$P(X6,U,10)
S FE=$P(X0,U,8)
S PI=$P(X0,U,10)
S IN1=$P(X0,U,16)
S CPT=$P(X0,U,17)
S ESSN=$P(X6,U,7)
S AGE=$P(X0,U,6)
Q
;----
BYIMIMM5 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
+1 ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
+2 ;
BRIDGE ;EP;TO MONITOR HL7 BRIDGE
+1 QUIT
STAT ;EP;TO DETERMINE BRIDGE STATUS
+1 QUIT
CANC ;
+1 QUIT
START ;
+1 QUIT
HOSTCMD ;
+1 SET X="S X=$$TERMINAL^%"_"HOSTCMD(HL7CMD)"
+2 XECUTE X
+3 QUIT
END ;
+1 KILL X,HL7FUNC,HL7CMD,HL7JOBN,HL7NAME,DIR
+2 SET BYIMQUIT=1
+3 QUIT
RXA(BYIMDA) ;EP;TO SET THE IIS CODE FOR RXA-11.4
+1 IF $GET(BYIMDA)=""
QUIT
+2 SET BYIMDA=+^AUTTSITE(1,0)
+3 IF $PIECE(^BYIMPARA(0),U,4)>1
IF '$DATA(^BYIMPARA(BYIMDA,0))
Begin DoDot:1
+4 WRITE !!,"BYIM Parameter Sites:"
+5 SET BYIMDA=0
+6 FOR
SET BYIMDA=$ORDER(^BYIMPARA(BYIMDA))
IF 'BYIMDA
QUIT
Begin DoDot:2
+7 WRITE !?10,$PIECE($GET(^DIC(4,BYIMDA,0)),U)
End DoDot:2
+8 SET DIC="^BYIMPARA("
+9 SET DIC(0)="AEMQZ"
+10 SET DIC("A")="Which BYIM Parameter Site: "
+11 DO ^DIC
+12 IF 'Y
SET BYIMDA=""
QUIT
+13 SET BYIMDA=+Y
End DoDot:1
+14 IF 'BYIMDA
QUIT
+15 IF '$DATA(^BYIMPARA(BYIMDA,1))
FOR
SET BYIMDA=$ORDER(^BYIMPARA(BYIMDA))
IF 'BYIMDA
QUIT
IF $DATA(^BYIMPARA(BYIMDA,"LAST EXPORT"))
QUIT
+16 IF 'BYIMDA
QUIT
+17 NEW BYIMRXA,DISP,BYIMQUIT
+18 IF $ORDER(^BYIMPARA(BYIMDA,5,0))
DO RXA1
QUIT
+19 WRITE !!,"Some state Immunization Information Systems (IIS) require facilities to send"
+20 WRITE !,"a code to identify the facility at which the immunization was administered or"
+21 WRITE !,"identify the vaccine inventory location instead of the facility name."
+22 WRITE !!,"If you need to add state IIS assigned code(s) please enter 'Y' below."
+23 WRITE !,"You will be prompted to select the name of your facility and then"
+24 WRITE !,"enter the state assigned code."
+25 KILL DIR
+26 SET DIR(0)="YO"
+27 SET DIR("A")="Add State IIS Assigned Facility Codes"
+28 SET DIR("B")="NO"
+29 WRITE !!
+30 DO ^DIR
+31 KILL DIR
+32 IF 'Y
QUIT
RXA1 NEW BYIMX
+1 SET BYIMQUIT=0
+2 FOR
DO RXAACT
IF BYIMQUIT
QUIT
+3 QUIT
+4 ;-----
RXAACT ;ADDITIONAL SITE ACTION
+1 IF '$ORDER(^BYIMPARA(BYIMDA,5,0))
DO RXAADD
+2 IF '$ORDER(^BYIMPARA(BYIMDA,5,0))
SET BYIMQUIT=1
QUIT
+3 DO RXADISP
+4 KILL DIR
+5 SET DIR(0)="SO^1:Edit Codes;2:Add codes;3:Delete codes"
+6 WRITE !!
+7 DO ^DIR
+8 KILL DIR
+9 IF 'Y
SET BYIMQUIT=1
QUIT
+10 IF Y=1
DO RXAEDIT
QUIT
+11 IF Y=2
DO RXAADD
QUIT
+12 IF Y=3
DO RXADEL
+13 QUIT
+14 ;-----
RXAADD ;SELECT FACILITIES FOR STATE RXA CODE
+1 NEW BYIMX,BYIMY
+2 SET DIC="^DIC(4,"
+3 SET DIC(0)="AEMQZ"
+4 ;S DIC("S")="I $D(^AUTTSITE(""B"",Y))!$D(^AUTTSITE(1,19251,""B"",Y))"
+5 SET DIC("A")="Select Facility for the IIS assigned Code: "
+6 WRITE !
+7 DO ^DIC
+8 IF Y<1
SET BYIMQUIT=1
QUIT
+9 SET BYIMX=+Y
+10 SET BYIMY=$PIECE(^DIC(4,+Y,0),U)
+11 KILL DIR
+12 SET DIR(0)="FO^1:50"
+13 SET DIR("A")="Enter State IIS Code assigned for **"_BYIMY_"**"
+14 WRITE !
+15 DO ^DIR
+16 KILL DIR
+17 IF X=""
SET BYIMQUIT=1
QUIT
+18 SET BYIMY=X
+19 SET X=BYIMX
+20 SET DA(1)=$ORDER(^BYIMPARA(0))
+21 SET DIC="^BYIMPARA("_$$DUZ^BYIMIMM()_",5,"
+22 SET DIC(0)="L"
+23 SET DIC("DR")=".02////"_BYIMY
+24 SET DINUM=X
+25 DO FILE^DICN
+26 IF Y<1
SET BYIMQUIT=1
QUIT
+27 QUIT
+28 ;------
RXADISP ;DISPLAY EXISTING IIS RXA CODES
+1 NEW DISP,J,X,Y,Z
+2 SET J=0
+3 SET X=0
+4 FOR
SET X=$ORDER(^BYIMPARA($$DUZ^BYIMIMM(),5,X))
IF 'X
QUIT
SET Y=$GET(^(X,0))
IF Y
Begin DoDot:1
+5 SET Z=$PIECE($GET(^DIC(4,X,0)),U)
+6 IF Z=""
QUIT
+7 SET Z=Z_" (IEN "_X_")"
+8 SET J=J+1
+9 SET X(Z)=Y
End DoDot:1
+10 SET J=0
+11 SET X=""
+12 FOR
SET X=$ORDER(X(X))
IF X=""
QUIT
Begin DoDot:1
+13 SET J=J+1
+14 SET $EXTRACT(DISP(J),11)=J
+15 SET $EXTRACT(DISP(J),16)=X
+16 SET $EXTRACT(DISP(J),60)=$PIECE(X(X),U,2)
+17 SET BYIMRXA(J)=+X(X)
End DoDot:1
+18 SET BYIMJ=J
+19 WRITE @IOF
+20 WRITE !?5,"State IIS Assigned Administered-at or Vaccine Inventory Location Code"
+21 WRITE !!?10,"NO."
+22 WRITE ?15,"Facility"
+23 WRITE ?59,"IIS Code"
+24 WRITE !?10,"---",?15,"------------------------------",?59,"--------------------"
+25 SET J=0
+26 FOR
SET J=$ORDER(DISP(J))
IF 'J
QUIT
Begin DoDot:1
+27 WRITE !,DISP(J)
End DoDot:1
+28 QUIT
+29 ;------
RXAEDIT ;EDIT SITE
+1 DO RXASEL
+2 IF '$GET(DA)
QUIT
RXAE1 SET DA(1)=BYIMDA
+1 SET DR=".02T"
+2 SET DIE="^BYIMPARA("_BYIMDA_",5,"
+3 WRITE !!,"Edit IIS Facility Code for: ",$PIECE($GET(^DIC(4,DA,0)),U)
+4 DO ^DIE
+5 KILL DA,DR,DIE
+6 QUIT
+7 ;-----
RXADEL ;DELETE SITE
+1 DO RXASEL
+2 IF '$GET(DA)
QUIT
+3 SET X=+^BYIMPARA(BYIMDA,5,DA,0)
+4 SET X=$PIECE($GET(^DIC(4,X,0)),U)
+5 WRITE !?10,X
+6 KILL DIR
+7 SET DIR(0)="YO"
+8 SET DIR("A")="Delete export/import site: "_X
+9 SET DIR("B")="NO"
+10 WRITE !
+11 DO ^DIR
+12 KILL DIR
+13 IF Y'=1
QUIT
+14 SET DA(1)=BYIMDA
+15 SET DIK="^BYIMPARA("_BYIMDA_",5,"
+16 DO ^DIK
+17 KILL DA,DIK
+18 QUIT
+19 ;-----
RXASEL ;SELECT ADDITION SITE
+1 IF BYIMJ=1
SET Y=1
DO RXASEL1
QUIT
+2 KILL DIR
+3 SET DIR(0)="NO^1:"_BYIMJ
+4 SET DIR("A")="Select Facility number"
+5 WRITE !!
+6 DO ^DIR
+7 KILL DIR
RXASEL1 IF 'Y
QUIT
+1 IF '$GET(BYIMRXA(Y))
QUIT
+2 SET DA=BYIMRXA(Y)
+3 QUIT
+4 ;-----
TEST ;EP;CREATE & SEND TEST MESSAGES
+1 ;PATCH 8 CR 08626 - INCLUDE/EXCLUDE PREVIOUSLY EXPORTED
+2 ;PATCH 8 CR 08695 - INCLUDE/EXCLUDE HISTORIC IMMS
+3 ;PATCH 8 CR 08694 - EXCLUDE IMM PRIOR TO SELECTED DATE
+4 KILL DIR,BYIMFILE
+5 WRITE @IOF
+6 WRITE !!?10,"Select group of patients for TEST export"
+7 SET DIR(0)="SO^1:Random group of patients;2:Select patients for test export"
+8 SET DIR("A")="Which group of patients"
+9 SET DIR("B")="Random group of patients"
+10 WRITE !!
+11 DO ^DIR
+12 KILL DIR
+13 IF 'Y
QUIT
+14 IF Y=2
DO SEL^BYIMIMM3
QUIT
+15 NEW Y
+16 SET Y=$PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,6)
+17 SET YEARS=$SELECT('Y:19,Y=1:65,1:99)
+18 SET CHILD=$SELECT('Y:"Children",1:"Patients")
+19 WRITE @IOF
+20 WRITE !!?10,"TEST export option"
+21 WRITE !!?10,"An export file will be created for"
+22 WRITE !?10,CHILD," ",$SELECT(YEARS=19:"18 years of age or under.",1:"of all ages.")
+23 WRITE !!
+24 KILL DIR
+25 ;PATCH 8 CR 08386 - CHANGE DEFAULT FROM 10 TO 1
+26 ;S DIR(0)="NO^10:1000"
+27 SET DIR(0)="NO^1:1000"
+28 ;PATCH 8 CR 08386 END
+29 SET DIR("A",1)="Enter the number of patients"
+30 SET DIR("A")="to include in the test export"
+31 SET DIR("B")="10"
+32 DO ^DIR
+33 KILL DIR
+34 IF 'Y
QUIT
+35 KILL BYIMTEST
+36 SET BYIMTEST=Y
+37 DO TSPEC
+38 KILL DIR
+39 SET DIR(0)="YO"
+40 SET DIR("A")="Proceed with test export of "_BYIMTEST_" patients"
+41 SET DIR("B")="NO"
+42 WRITE !!
+43 DO ^DIR
+44 KILL DIR
+45 IF 'Y
QUIT
+46 KILL ^BYIMTMP($JOB,"BYIM EXP")
+47 NEW XX,X,Y,Z,DOB,DFN,VIS,J
+48 SET J=0
+49 SET VIS=$ORDER(^AUPNVSIT(9999999999),-1)-$RANDOM(10)
+50 FOR
SET VIS=$ORDER(^AUPNVIMM("AD",VIS),-1)
IF 'VIS!(J>(BYIMTEST-1))
QUIT
Begin DoDot:1
+51 ;PATCH 8 CR 08694 - SELECT ONLY BEFORE START DATE WHEN START DATE SET
+52 NEW DAT
+53 SET DAT=+$PIECE($GET(^AUPNVSIT(VIS,0)),".")
+54 IF $LENGTH(DAT)'=7
QUIT
+55 IF BYIMEDAT
IF DAT<BYIMEDAT
QUIT
+56 ;PATCH 8 CR 08694 END
+57 ;ENSURE DIRECT/ADMINISTERED - NON-HISTORIC - VISIT TYPE
+58 IF BYIMADM=1
IF "CTNOEDXM"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+59 SET X=$ORDER(^AUPNVIMM("AD",VIS,0))
+60 IF 'X
QUIT
+61 SET X=$GET(^AUPNVIMM(X,0))
+62 SET DFN=+$PIECE(X,U,2)
+63 IF 'DFN
QUIT
+64 IF $GET(^DPT(DFN,.35))
QUIT
+65 IF '$GET(^AUPNPAT(DFN,0))
QUIT
+66 IF $DATA(^BYIMTMP($JOB,"BYIM EXP",DFN))
QUIT
+67 IF BYIMALL'=2!(BYIMADM'=2)
IF '$$NEW^BYIMIMM6(DFN,BYIMALL,BYIMADM,BYIMEDAT)
QUIT
+68 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
+69 IF '$PIECE($GET(^BYIMPARA($$DUZ^BYIMIMM(),0)),U,6)
IF DOB<(DT-180000)
QUIT
+70 SET ^BYIMTMP($JOB,"BYIM EXP",DFN,VIS)=""
+71 SET J=J+1
+72 SET JX=0
+73 SET JY=0
+74 NEW IMM
+75 SET IMM=0
+76 FOR
SET IMM=$ORDER(^AUPNVIMM("AC",DFN,IMM))
IF 'IMM
QUIT
Begin DoDot:2
+77 SET JX=JX+1
+78 NEW IVIS
+79 SET IVIS=$PIECE($GET(^AUPNVIMM(IMM,0)),U,3)
+80 IF 'IVIS
QUIT
End DoDot:2
End DoDot:1
+81 SET MSGCNT=BYIMTEST+1
+82 SET XX=$PIECE($HOROLOG,",",2)
+83 DO FN^BYIMIMM
+84 NEW DDATE
+85 SET (DDATE,DDDATE)=$ORDER(^BYIMPARA($$DUZ^BYIMIMM(),"LAST EXPORT",9999999999),-1)
+86 DO DEX^BYIMIMM
+87 QUIT
+88 ;-----
CLEAN ;EP;CLEAN UP AFTER TEST EXPORT
+1 NEW IMM
+2 SET IMM=0
+3 FOR
SET IMM=$ORDER(^BYIMTMP("TEST",IMM))
IF 'IMM
QUIT
Begin DoDot:1
+4 ;REMOVE 'D' WHEN SET BY TEST
+5 KILL ^BYIMEXP("D",IMM),^BYIMTMP("TEST",IMM)
End DoDot:1
+6 SET IMM=0
+7 FOR
SET IMM=$ORDER(^BYIMTMP("TEST ALL",IMM))
IF 'IMM
QUIT
Begin DoDot:1
+8 ;RESET 'D' WHEN REMOVED BY TEST
+9 SET ^BYIMEXP("D",IMM,+$ORDER(^BYIMTMP("TEST ALL",IMM,"")))=""
+10 KILL ^BYIMTMP("TEST ALL",IMM)
End DoDot:1
+11 ;PATCH 8 CR 08626 END
+12 ;PATCH 8 CR 08695 END
+13 ;PATCH 8 CR 08694 END
+14 QUIT
+15 ;-----
TSPEC ;SELECT SPECIFICATIONS FOR TEST EXPORT
+1 KILL BYIMEDAT,BYIMADM,BYIMALL
+2 WRITE @IOF
+3 WRITE !!?10,"Default TEST export criteria"
+4 SET BYIMEDAT=""
+5 SET BYIMEDAT(0)=""
+6 SET BYIMADM=1
+7 SET BYIMALL=1
+8 DO TSHOW
+9 KILL DIR
+10 SET DIR(0)="LO^1:3"
+11 SET DIR("A",1)=" 1. Specify start date for immunizations to include"
+12 SET DIR("A",2)=" 2. Exclude HISTORIC immunizations"
+13 SET DIR("A",3)=" 3. Exclude PREVIOUSLY EXPORTED immunizations"
+14 SET DIR("A",4)=" "
+15 SET DIR("A")="Select all criteria you want to set"
+16 WRITE !!
+17 DO ^DIR
+18 KILL DIR
+19 IF 'Y
QUIT
+20 SET BYIMY=Y
+21 FOR J=1:1:$LENGTH(BYIMY,",")-1
SET SR="T"_$PIECE(BYIMY,",",J)
DO @SR
+22 IF 'BYIMEDAT&'BYIMADM&'BYIMALL
QUIT
+23 DO TSHOW
+24 QUIT
TSHOW ;SHOW TEST EXPORT CRITERIA
+1 WRITE !!!?10,"TEST Export Criteria:"
+2 WRITE !!,"Start date: ",BYIMEDAT(0)
+3 WRITE !!
+4 IF BYIMADM=2
Begin DoDot:1
+5 WRITE "Administered and historic"
End DoDot:1
IF 1
+6 IF '$TEST
WRITE "Only administered"
+7 WRITE " and ",!
+8 IF BYIMALL=2
Begin DoDot:1
+9 WRITE "new and previously exported"
End DoDot:1
IF 1
+10 IF '$TEST
WRITE "never exported"
+11 WRITE !,"immunizations will be included in the test export."
+12 QUIT
+13 ;-----
T1 ;SELECT TEST EXPORT DATE
+1 ;PATCH 8 CR 08694 - EXCLUDE IMM PRIOR TO SELECTED DATE
+2 KILL DIR
+3 SET DIR(0)="DO"
+4 SET DIR("A")="Select start date for the TEST export"
+5 WRITE !!
+6 DO ^DIR
+7 KILL DIR
+8 IF 'X
QUIT
+9 SET BYIMEDAT=Y
SET BYIMEDAT(0)=Y(0)
+10 ;PATCH 8 CR 08694 END
+11 QUIT
+12 ;-----
T2 ;INCLUDE ONLY ADMINISTERED IMMUNIZATIONS
+1 ;PATCH 8 CR 08695 - INCLUDE/EXCLUDE HISTORIC IMMS
+2 SET BYIMADM=1
+3 KILL DIR
+4 SET DIR(0)="YO"
+5 SET DIR("A")="Exclude HISTORIC immunizations"
+6 SET DIR("B")="YES"
+7 WRITE !
+8 DO ^DIR
+9 KILL DIR
+10 IF X[U
QUIT
+11 SET BYIMADM=1
+12 IF 'Y
SET BYIMADM=2
QUIT
+13 SET BYIMADM=1
+14 ;PATCH 8 CR 08695 - END
+15 QUIT
+16 ;-----
T3 ;EXCLUDE PREVIOUSLY EXPORTED IMMUNIZATIONS
+1 ;PATCH 8 CR 08626 - INCLUDE/EXCLUDE PREVIOUSLY EXPORTED
+2 ;BYIMALL=1 EXPORT ONLY NEW, NOT YET EXPORTED IMMS
+3 ;BYIMALL=2 EXPORT NEW AND PREVIOUSLY EXPORTED IMMS
+4 SET BYIMALL=1
+5 KILL DIR
+6 SET DIR(0)="YO"
+7 SET DIR("A")="Exclude PREVIOUSLY EXPORTED immunizations"
+8 SET DIR("B")="YES"
+9 WRITE !
+10 DO ^DIR
+11 KILL DIR
+12 IF X[U
QUIT
+13 IF 'Y
SET BYIMALL=2
QUIT
+14 SET BYIMALL=1
+15 ;PATCH 8 CR 08626 - END
+16 QUIT
+17 ;-----
COMPSPEC ;EP;TO SPECIFY MESSAGE COMPONENT CONTENT
+1 ;N X,Y,Z,XX,SEG,COMP,SCOMP,VAL,BYIMQUIT
+2 SET BYIMQUIT=0
+3 FOR
DO CS
IF BYIMQUIT
QUIT
+4 QUIT
+5 ;-----
CS ;REPEAT
+1 DO CDISP
+2 IF '$ORDER(COMP(0))
SET QUIT=1
QUIT
+3 DO CSEL
+4 QUIT
+5 ;-----
CDISP ;EP;DISPLAY COMPONENTS FOR PRIMARY SITE
+1 SET SITE=$PIECE(^DIC(4,$$DUZ^BYIMIMM(),0),U)
+2 DO CHDR(SITE)
+3 SET X=0
+4 FOR
SET X=$ORDER(^BYIMPARA($$DUZ^BYIMIMM(),7,X))
IF 'X
QUIT
SET Y=^(X,0)
Begin DoDot:1
+5 SET SEG=$PIECE(Y,U)
+6 SET COMP=$PIECE(Y,U,2)
+7 SET SCOMP=$PIECE(Y,U,3)
+8 IF 'COMP!'SCOMP
QUIT
+9 SET VAL=$PIECE(Y,U,4)_U_X
+10 IF SEG="MSH"
SET SEG="1-MSH"
+11 IF SEG="PID"
SET SEG="2-PID"
+12 IF SEG="PD1"
SET SEG="3-PD1"
+13 IF SEG="NK1"
SET SEG="4-NK1"
+14 IF SEG="PV1"
SET SEG="5-PV1"
+15 IF SEG="ORC"
SET SEG="6-ORC"
+16 IF SEG="RXA"
SET SEG="7-RXA"
+17 SET XX(SEG,COMP,SCOMP)=VAL
End DoDot:1
+18 DO CD
+19 QUIT
+20 ;-----
CAS(AS) ;EP;DISPLAY COMPONENTS FOR ADDITIONAL EXPORT SITES
+1 SET SITE=$PIECE(^BYIMPARA($$DUZ^BYIMIMM(),3,AS,0),U)
+2 DO CHDR(SITE)
+3 NEW X,Y,Z,XX,SEG,SCOMP,VAL
+4 SET X=0
+5 FOR
SET X=$ORDER(^BYIMPARA($$DUZ^BYIMIMM(),3,AS,7,X))
IF 'X
QUIT
SET Y=^(X,0)
Begin DoDot:1
+6 SET SEG=$PIECE(Y,U)
+7 SET COMP=$PIECE(Y,U,2)
+8 SET SCOMP=$PIECE(Y,U,3)
+9 SET VAL=$PIECE(Y,U,4)
+10 IF SEG="MSH"
SET SEG="1-MSH"
+11 IF SEG="PID"
SET SEG="2-PID"
+12 IF SEG="PD1"
SET SEG="3-PD1"
+13 IF SEG="NK1"
SET SEG="4-NK1"
+14 IF SEG="PV1"
SET SEG="5-PV1"
+15 IF SEG="ORC"
SET SEG="6-ORC"
+16 IF SEG="RXA"
SET SEG="7-RXA"
+17 SET XX(SEG,COMP,SCOMP)=X_U_VAL
End DoDot:1
+18 DO CD
+19 QUIT
+20 ;-----
CD ;
+1 SET JJ=0
+2 SET X=""
+3 FOR
SET X=$ORDER(XX(X))
IF X=""
QUIT
Begin DoDot:1
+4 SET Y=0
+5 FOR
SET Y=$ORDER(XX(X,Y))
IF 'Y
QUIT
Begin DoDot:2
+6 SET Z=0
+7 FOR
SET Z=$ORDER(XX(X,Y,Z))
IF 'Z
QUIT
SET VAL=XX(X,Y,Z)
Begin DoDot:3
+8 SET JJ=JJ+1
+9 WRITE !,JJ,?5,$PIECE(X,"-",2),?18,Y,?30,Z,?39,$PIECE(VAL,U)
+10 SET COMP(JJ)=+VAL_U_$PIECE(X,"-",2)
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET BYIMJ=JJ
+12 QUIT
+13 ;
CHDR(SITE) ;DISPLAY COMPONENT HEADER
+1 WRITE @IOF
+2 WRITE !!?15,"HL7 State Specified Message Components"
+3 WRITE !?15,"For: ",SITE
+4 WRITE !!?27,"Sub-"
+5 WRITE !,"NO",?5,"Segment",?15,"Component",?27,"Component",?39,"Value"
+6 WRITE !,"--",?5,"-------",?15,"---------",?27,"---------",?39,"--------------------------"
+7 QUIT
+8 ;-----
CADD ;ADD ADDITIONAL COMPONENTS
+1 SET DIR(0)="SO^1:MSH;2:PID;3:PD1;4:NK1;5:PV1;6:ORC;7:RXA"
+2 SET DIR("A")="Select a segment for component specification"
+3 WRITE !!
+4 DO ^DIR
+5 KILL DIR
+6 IF 'Y
QUIT
+7 SET SEG=Y(0)
+8 IF $DATA(^BYIMPARA($$DUZ^BYIMIMM(),7,"SEG",X))
Begin DoDot:1
+9 SET DIR(0)="YO"
+10 SET DIR("A")="ADD another "_SEG_" component"
+11 WRITE !!
+12 DO ^DIR
End DoDot:1
+13 IF 'Y
QUIT
+14 SET X=SEG
+15 SET DA(1)=$ORDER(^BYIMPARA(0))
+16 SET DIC="^BYIMPARA("_DA(1)_",7,"
+17 SET DIC(0)="L"
+18 DO FILE^DICN
+19 IF 'Y
QUIT
+20 DO CE(+Y,SEG)
+21 QUIT
+22 ;-----
CEDIT ;EDIT COMPONENTS
+1 KILL DIR
+2 SET DIR(0)="NO^1:"_BYIMJ
+3 SET DIR("A")="Select Component to edit"
+4 WRITE !!
+5 DO ^DIR
+6 KILL DIR
+7 IF 'Y
QUIT
+8 SET SEG=$PIECE(COMP(Y),U,2)
+9 DO CE(Y)
+10 QUIT
+11 ;-----
CE(DA,SEG) SET DIE="^BYIMPARA("_$$DUZ^BYIMIMM()_",7,"
+1 SET DA(1)=$ORDER(^BYIMPARA(0))
+2 SET DA=DA
+3 SET DR=".02;.03;.04"
+4 WRITE !!,"Edit ",SEG," info",!
+5 DO ^DIE
+6 QUIT
+7 ;-----
CDEL ;DELETE COMPONENTS
+1 QUIT
+2 ;-----
CSEL ;EP;TO DISPLAY AND ADD/EDIT COMPONENTS
+1 DO CDISP
+2 KILL DIR
+3 SET DIR(0)="SO^1:Edit Message Components;2:Add Message Components;3:Delete Message Components"
+4 WRITE !!
+5 DO ^DIR
+6 KILL DIR
+7 IF 'Y
SET BYIMQUIT=1
QUIT
+8 IF Y=1
DO CEDIT
QUIT
+9 IF Y=2
DO CADD
QUIT
+10 IF Y=3
DO CDEL
+11 QUIT
+12 ;-----
AGECHK(UIF) ;EP;
+1 ;TO CHECK EXPORT AGE OF ADD. EXPORT SITE VERSUS EXPORT AGE OF
+2 ;PRIMARY SITE
+3 NEW MSH,PID,DOB,D19
+4 IF '$GET(UIF)
QUIT 0
+5 SET MSH=$GET(^INTHU(UIF,3,1,0))
+6 IF MSH'["MSH|"
QUIT 0
+7 SET PID=$GET(^INTHU(UIF,3,2,0))
+8 IF PID=""
QUIT 0
+9 SET DOB=$PIECE(PID,"|",8)-17000000
+10 IF $LENGTH(DOB)'=7
QUIT 0
+11 ;CHANGE TO FM DATE FORMAT AND 19 YEARS
SET D19=(DT-190000)
+12 IF DOB<D19
QUIT 1
+13 QUIT 0
+14 ;-----
ASSET(AS) ;EP;SITE STATE VARIABLES
+1 IF AS=BYIMDUZ
Begin DoDot:1
+2 SET X0=$GET(^BYIMPARA(BYIMDUZ,0))
+3 SET X1=$GET(^BYIMPARA(BYIMDUZ,1))
+4 SET X6=$GET(^BYIMPARA(BYIMDUZ,6))
End DoDot:1
+5 IF AS'=BYIMDUZ
Begin DoDot:1
+6 SET X0=$GET(^BYIMPARA(BYIMDUZ,3,AS,0))
+7 SET X1=$GET(^BYIMPARA(BYIMDUZ,3,AS,1))
+8 SET X6=$GET(^BYIMPARA(BYIMDUZ,3,AS,6))
End DoDot:1
+9 SET PATH=$$SLASH^BYIMIMM6($PIECE(X0,U,2))
+10 SET (XX("MSH",3,1),XX("FHS",3,1),XX("BHS",3,1))=$PIECE(X1,U,3)
+11 SET (XX("MSH",3,2),XX("FHS",3,2),XX("BHS",3,2))=$PIECE(X1,U,4)
+12 SET (XX("MSH",3,3),XX("FHS",3,3),XX("BHS",3,3))=$PIECE(X1,U,5)
+13 SET (XX("MSH",4,1),XX("FHS",4,1),XX("BHS",4,1))=$PIECE(X0,U,7)
+14 SET (XX("MSH",4,2),XX("FHS",4,2),XX("BHS",4,2))=$PIECE(X1,U,6)
+15 SET (XX("MSH",4,3),XX("FHS",4,3),XX("BHS",4,3))=$PIECE(X1,U,7)
+16 SET XX("MSH",5,1)=$PIECE(X6,U,3)
+17 SET XX("MSH",5,2)=$PIECE(X6,U,4)
+18 SET XX("MSH",5,3)=$PIECE(X6,U,5)
+19 SET XX("MSH",6,1)=$PIECE(X1,U,8)
+20 SET XX("MSH",8,1)=$PIECE(X0,U,15)
+21 SET XX("MSH",11,1)=$PIECE(X6,U,11)
+22 SET XX("PID",11,7)=$PIECE(X6,U,8)
+23 SET XX("PD1",3,1)=$PIECE(X6,U)
+24 SET XX("PD1",3,2)=$PIECE(X6,U,2)
+25 SET XX("PD1",3,3)=$PIECE(X6,U,9)
+26 SET XX("RXA",6,1)=$PIECE(X6,U,10)
+27 SET FE=$PIECE(X0,U,8)
+28 SET PI=$PIECE(X0,U,10)
+29 SET IN1=$PIECE(X0,U,16)
+30 SET CPT=$PIECE(X0,U,17)
+31 SET ESSN=$PIECE(X6,U,7)
+32 SET AGE=$PIECE(X0,U,6)
+33 QUIT
+34 ;----
