BYIMMU2 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8**;JUL 11, 2017;Build 310
;
;----
Q
ALL ;EP;
D MU2
H 5
D SEND
Q
MU2 ;EP;SETUP MU2 PATIENTS AND DATA
D WARN
I $G(BYIMQUIT) K BYIMQUIT Q
;I $D(^BYIMTMP("RESTORE")) D RESTORE
K ^BYIMTMP("MU2")
D MU21^BYIMMU21
D PAT
W !!,"NIST test environment prepared."
D PAUSE^BYIMIMM6
Q
;-----
PAT ;SET PATIENT DEMOGRAPHICS
K ^BYIMTMP("MU2","PAT")
S TT=10
S JJ=0
F IEN=$R(999):10 D Q:JJ=7&(TT=13)!(IEN>$P(^DPT(0),U,3))
.Q:'$D(^DPT(IEN,0))
.Q:'$D(^AUPNPAT(IEN,0))
.Q:'$D(^AUPNPAT(IEN,41,DUZ(2),0))
.Q:'$O(^AUPNVIMM("AC",IEN,0))
.Q:$O(^AUPNVIMM("AC",IEN,0))=$O(^AUPNVIMM("AC",IEN,9999999999),-1)
.K ^BYIMTMP("MU2","V7")
.S K=0
.S (J,X)=0
.F S X=$O(^AUPNVIMM("AC",IEN,X)) Q:'X!K D
..S VSIT=+$P($G(^AUPNVIMM(X,0)),U,3)
..S:'$D(^BYIMTMP("MU2","V7",VSIT)) J=J+1
..S ^BYIMTMP("MU2","V7",VSIT)=""
..I J>3 S K=1
.Q:'K
.S TT=TT+1
.S:TT=11 JJ=JJ+1
.S PID="P"_JJ_TT
.D P1(PID)
.I TT=13,JJ'=7 S TT=10
Q
;-----
P1(PID) ;PROCESS EACH PATIENT
;S PID="P"_JJ_TT
S YY=^BYIMTMP("MU2","DATA",PID)
S ZZ=""
S:$E(PID,1,3)="P11" L2=PID_2,ZZ=^BYIMTMP("MU2","DATA",L2)
K DA,DR,DIE
S DR=$P(YY,";",3)
S DR=$TR(DR,"|",";")
S NET=$P($P(YY,"1802////",2),";")
S NAM=$P($P(DR,".01////",2),";")
S DR=$P(DR,";",2,99)
I 0,$D(^DPT("B",NAM,IEN)) D Q
.I TT=11 S JJ=JJ-1
.S TT=TT-1
D NCLEAN(NAM,IEN)
M ^BYIMTMP("RESTORE","DPT",IEN)=^DPT(IEN)
M ^BYIMTMP("RESTORE","AUPNPAT",IEN)=^AUPNPAT(IEN)
W !,$J(IEN,6),?8,NAM,"..." H 1
S DA=IEN
S DIE="^DPT("
D ^DIE
D:ZZ]""
.S DA=IEN
.S DIE="^DPT("
.S DR=$P(ZZ,";",3)
.S DR=$TR(DR,"|",";")
.D ^DIE
S ^BYIMTMP("MU2","PAT",PID)=DA
S $P(^BIP(DA,0),U)=DA
S $P(^BIP(DA,0),U,8)=""
S $P(^BIP(DA,0),U,16)=""
S $P(^BIP(DA,0),U,21)=$P(^DPT(DA,0),U,3)
S $P(^BIP(DA,0),U,24)=1
S $P(^BIP(DA,0),U,25)=DT
K ^DPT(DA,.35)
S:NET]"" $P(^AUPNPAT(DA,18),U,2)=NET
D VISIT(DA,PID)
Q
;-----
VISIT(DFN,PID) ;SETUP VISIT DATA
N X,Y,Z
S NUM=$E(PID,2)
I NUM=7 D V7(DFN,PID) Q
S ID=$E(PID,2,5)
S LOS="T"_$E(PID,2,5)
S VID="V"_ID
S IID="I"_ID
S BIP="BIP"_ID
S REF="REF"_ID
S BIPC="BIPC"_ID
K:NUM'=5 ^AUPNPREF("AC",DFN)
K:NUM'=6 ^BIPC("B",DFN)
S X=0
F S X=$O(^AUPNVIMM("AC",DFN,X)) Q:'X S ^BYIMEXP("D",X)="",VIMM=X
I NUM<5 K ^BYIMEXP("D",VIMM)
S VSIT=$P(^AUPNVIMM(VIMM,0),U,3)
K DA,DR,DIE
S DA=VSIT
S DR=$P(^BYIMTMP("MU2","DATA",VID),";",3)
S DR=$TR(DR,"|",";")
D:DR]""
.M ^BYIMTMP("RESTORE","DPT",DFN,"VSIT",DA)=^AUPNVSIT(DA)
.S DIE="^AUPNVSIT("
.D ^DIE
.K DA,DR,DIE
K DA,DR,DIE
S DA=VIMM
S DR=$P(^BYIMTMP("MU2","DATA",IID),";",3)
S DR=$TR(DR,"|",";")
D:DR["P1202"
.S P1202=^BYIMTMP("MU2","PRV",1202)
.S P1204=^BYIMTMP("MU2","PRV",1204)
.S P1214=^BYIMTMP("MU2","PRV",1214)
.S DR=$P(DR,"P1202")_P1202_$P(DR,"P1202",2)
.S DR=$P(DR,"P1204")_P1204_$P(DR,"P1204",2)
.S DR=$P(DR,"P1214")_P1214_$P(DR,"P1214",2)
S:LOS]"" LOT=$G(^BYIMTMP("MU2","LOT",LOS))
I LOT,DR[LOS S DR=$P(DR,LOS)_LOT_$P(DR,LOS,2)
S DIE="^AUPNVIMM("
M ^BYIMTMP("RESTORE","DPT",DFN,"VIMM",DA)=^AUPNVIMM(DA)
D:DR]"" ^DIE
K DA,DR,DIE
D:NUM=4 BIP
;-----
D:NUM=5 REF
;-----
D:NUM=6 BIPC
;-----
Q
;-----
BIP ;
K DA,DR,DIE
S DA=DFN
S DR=$P(^BYIMTMP("MU2","DATA",BIP),";",3)
S DR=$TR(DR,"|",";")
S DIE="^BIP("
D ^DIE
K DA,DR,DIE
Q
;-----
REF ;
K DA,DR,DIE
S DA=$O(^AUPNPREF("AC",DFN,0))
D:'DA
.S X=3
.S DIC="^AUPNPREF("
.S DIC(0)="L"
.S DIC("DR")=".02////"_DFN
.D FILE^DICN
.S DA=+Y
K ^BYIMEXP("REF",DA)
S DR=$P(^BYIMTMP("MU2","DATA",REF),";",3)
S DR=$TR(DR,"|",";")
S DR=$P(DR,"DFN")_DFN_$P(DR,"DFN",2)
S DIE="^AUPNPREF("
D ^DIE
K DA,DR,DIE
Q
;-----
BIPC ;
K DA,DR,DIE
S DA=$O(^BIPC("B",DFN,0))
D:'DA
.S X=DFN
.S DIC="^BIPC("
.S DIC(0)="L"
.S DIR("DR")=".02////132"
.D FILE^DICN
.K DIC
.S DA=+Y
K ^BYIMEXP("HXV",DA)
S DR=$P(^BYIMTMP("MU2","DATA",BIPC),";",3)
S DR=$TR(DR,"|",";")
S DR=$P(DR,"DFN")_DFN_$P(DR,"DFN",2)
S DIE="^BIPC("
D ^DIE
K DA,DR,DIE
Q
;-----
SEND ;EP;SEND RT VXU MU2 MESSAGES
;D WARN
N BYIMMU2
S BYIMMU2=1
I $G(BYIMQUIT) K BYIMQUIT Q
W !!,"Please stand by while I create and send the NIST messages...",!
S SCN=""
F S SCN=$O(^BYIMTMP("MU2","PAT",SCN)) Q:SCN="" S DFN=^(SCN) D
.S RT="VXU"
.;PATCH 8 CR 08626 - SEND ONLY ADMINISTERED IMMS
.S BYIMALL=1
.;PATCH 8 CR 08626 END
.D VXU^BYIMRT(DFN)
H 30
;D RESTORE
Q
;-----
V7(DFN,PID) ;SETUP VISIT DATA
K ^BYIMTMP("MU2","V7")
N X,Y,Z
S NUM=7
S ID=$E(PID,2,5)
S LOS="T"_$E(PID,2,5)
S VID="V"_ID
S IID="I"_ID
K ^AUPNPREF("AC",DFN)
K ^BIPC("B",DFN)
S CNT=1
S X=0
F S X=$O(^AUPNVIMM("AC",DFN,X)) Q:'X D
.S ^BYIMEXP("D",X)=""
.S V=$P($G(^AUPNVIMM(X,0)),U,3)
.I CNT<4,'$D(^BYIMTMP("MU2","V7",V)) D
..S TMP(CNT)=V_U_X
..S CNT=CNT+1
..K ^BYIMEXP("D",X)
..S ^BYIMTMP("MU2","V7",V)=""
D P7(DFN,PID,.TMP)
Q
;-----
P7(DFN,PID,TMP) ;PROCESS SCENARIO 7 VISITS
N CNT
S CNT=0
F CNT=1,2,3 S X=TMP(CNT) D
.S VSIT=+X
.Q:'VSIT
.S VIMM=$P(X,U,2)
.K ^BYIMEXP("D",VIMM)
.S ^BYIMTMP("MU2","V7",VSIT)=""
.D:CNT>1
..S VID=$E(VID,1,4)_CNT
..S IID=$E(IID,1,4)_CNT
.S (LOS,LOT)=""
.S:CNT=1 LOS="T"_$E(PID,2,4)
.S:CNT=3 LOS="T"_$E(PID,2,4)_3
.K DA,DR,DIE
.S DA=VSIT
.S DR=$P(^BYIMTMP("MU2","DATA",VID),";",3)
.S DR=$TR(DR,"|",";")
.M ^BYIMTMP("RESTORE","DPT",DFN,"VSIT",DA)=^AUPNVSIT(DA)
.S DIE="^AUPNVSIT("
.D ^DIE
.K DA,DR,DIE
.S DA=VIMM
.S DR=$P(^BYIMTMP("MU2","DATA",IID),";",3)
.S DR=$TR(DR,"|",";")
.S:LOS]"" LOT=$G(^BYIMTMP("MU2","LOT",LOS))
.I LOT,DR[LOS S DR=$P(DR,LOS)_LOT_$P(DR,LOS,2)
.D:DR["P1202"
..S P1202=^BYIMTMP("MU2","PRV",1202)
..S P1204=^BYIMTMP("MU2","PRV",1204)
..S P1214=^BYIMTMP("MU2","PRV",1214)
..S DR=$P(DR,"P1202")_P1202_$P(DR,"P1202",2)
..S DR=$P(DR,"P1204")_P1204_$P(DR,"P1204",2)
..S DR=$P(DR,"P1214")_P1214_$P(DR,"P1214",2)
.S DIE="^AUPNVIMM("
.M ^BYIMTMP("RESTORE","DPT",DFN,"VIMM",DA)=^AUPNVIMM(DA)
.D ^DIE
.K DA,DR,DIE
K ^BYIMTMP("MU2","V7",VSIT)
Q
;-----
NCLEAN(NAM,IEN) ;CLEAN 'B' XREF
S ^DPT("B",NAM,IEN)=""
N X,Y,Z
S X=0
F S X=$O(^DPT("B",NAM,X)) Q:'X I X'=IEN K ^DPT("B",NAM,X)
Q
;-----
RESTORE ;RESTORE ORIGINAL DPT AND AUPNPAT CONTENT
Q W !!,"Please stand by while I restore the pre-NIST environment...",!
S DFN=0
F S DFN=$O(^BYIMTMP("RESTORE","AUPNPAT",DFN)) Q:'DFN D R1(DFN)
RPRV S PRV=0
F S PRV=$O(^BYIMTMP("RESTORE","PRV",PRV)) Q:'PRV D
.M ^VA(200,PRV)=^BYIMTMP("RESTORE","PRV",PRV)
.K DA,DIK
.S DA=PRV
.S DIK="^VA(200,"
.D IX1^DIK
.K DA,DIK
RIML S IML=0
F S IML=$O(^BYIMTMP("RESTORE","IML",IML)) Q:'IML D
.M ^AUTTIML(IML)=^BYIMTMP("RESTORE","IML",IML)
.K DA,DIK
.S DA=IML
.S DIK="^AUTTIML("
.D IX1^DIK
.K DA,DIK
RIMM S IMM=0
F S IMM=$O(^BYIMTMP("RESTORE","IMM",IMM)) Q:'IMM D
.M ^AUTTIMM(IMM)=^BYIMTMP("RESTORE","IMM",IMM)
.K DA,DIK
.S DA=IMM
.S DIK="^AUTTIMM("
.D IX1^DIK
.K DA,DIK
S X=0
F S X=$O(^BYIMTMP("RESTORE","AUPNPAT",X)) Q:'X I $D(^AUPNPAT(X,0)) K ^BYIMTMP("RESTORE","AUPNPAT",X)
I $O(^BYIMTMP("RESTORE","AUPNPAT",0)) W !!,"AUPNPAT... Pending"
E K ^BYIMTMP("RESTORE")
W !!,"Database RESTORE process complete."
D PAUSE^BYIMIMM6
Q
;-----
R1(DFN) ;DO RESTORE
M ^AUPNPAT(DFN)=^BYIMTMP("RESTORE","AUPNPAT",DFN)
K DA,DIK
S DA=DFN
S DIK="^AUPNPAT("
D IX1^DIK
K DA,DIK
M ^DPT(DFN)=^BYIMTMP("RESTORE","DPT",DFN)
S DA=DFN
S DIK="^DPT("
D IX1^DIK
K DA,DIK
VSIT S VSIT=0
F S VSIT=$O(^BYIMTMP("RESTORE","DPT",DFN,"VSIT",VSIT)) Q:'VSIT D
.M ^AUPNVSIT(VSIT)=^BYIMTMP("MU2","DPT",DFN,"VSIT",VSIT)
.K DA,DIK
.S DA=VSIT
.S DIK="^AUPNVSIT("
.D IX1^DIK
.K DA,DIK
VIMM S VIMM=0
F S VIMM=$O(^BYIMTMP("RESTORE","DPT",DFN,"VIMM",VIMM)) Q:'VIMM D
.M ^AUPNVIMM(VIMM)=^BYIMTMP("RESTORE","DPT",DFN,"VIMM",VIMM)
.K DA,DIK
.S DA=VIMM
.S DIK="^AUPNVIMM("
.D IX1^DIK
.K DA,DIK
Q
;-----
WARN ;CHECK FOR TEST DATABASE
W @IOF
W !?10,"Warning - Warning - Warning"
W !!?10,"The BYIM automated NIST Process - PREP, SEND and RESTORE"
W !?10,"can only be run on a test database, never on a production database"
K DIR
S DIR(0)="YO"
S DIR("A")="Do you certify that this is a TEST database"
S DIR("B")="NO"
W !
D ^DIR
K DIR
I Y'=1 D Q
.S BYIMQUIT=1
.W !!,"Please run the BYIM automated NIST Process on a test database"
.H 4
Q
;-----
MPAT ;EP;SETUP MASTER DB PATIENTS
D MU21^BYIMMU21
S PID=""
F S PID=$O(^BYIMTMP("PAT",PID)) Q:PID="" S IEN=^(PID),JJ=$E(PID,2),TT=$E(PID,2,3) D P1(PID)
Q
MSEND D SEND
Q
;-----
BYIMMU2 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
+1 ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8**;JUL 11, 2017;Build 310
+2 ;
+3 ;----
+4 QUIT
ALL ;EP;
+1 DO MU2
+2 HANG 5
+3 DO SEND
+4 QUIT
MU2 ;EP;SETUP MU2 PATIENTS AND DATA
+1 DO WARN
+2 IF $GET(BYIMQUIT)
KILL BYIMQUIT
QUIT
+3 ;I $D(^BYIMTMP("RESTORE")) D RESTORE
+4 KILL ^BYIMTMP("MU2")
+5 DO MU21^BYIMMU21
+6 DO PAT
+7 WRITE !!,"NIST test environment prepared."
+8 DO PAUSE^BYIMIMM6
+9 QUIT
+10 ;-----
PAT ;SET PATIENT DEMOGRAPHICS
+1 KILL ^BYIMTMP("MU2","PAT")
+2 SET TT=10
+3 SET JJ=0
+4 FOR IEN=$RANDOM(999):10
Begin DoDot:1
+5 IF '$DATA(^DPT(IEN,0))
QUIT
+6 IF '$DATA(^AUPNPAT(IEN,0))
QUIT
+7 IF '$DATA(^AUPNPAT(IEN,41,DUZ(2),0))
QUIT
+8 IF '$ORDER(^AUPNVIMM("AC",IEN,0))
QUIT
+9 IF $ORDER(^AUPNVIMM("AC",IEN,0))=$ORDER(^AUPNVIMM("AC",IEN,9999999999),-1)
QUIT
+10 KILL ^BYIMTMP("MU2","V7")
+11 SET K=0
+12 SET (J,X)=0
+13 FOR
SET X=$ORDER(^AUPNVIMM("AC",IEN,X))
IF 'X!K
QUIT
Begin DoDot:2
+14 SET VSIT=+$PIECE($GET(^AUPNVIMM(X,0)),U,3)
+15 IF '$DATA(^BYIMTMP("MU2","V7",VSIT))
SET J=J+1
+16 SET ^BYIMTMP("MU2","V7",VSIT)=""
+17 IF J>3
SET K=1
End DoDot:2
+18 IF 'K
QUIT
+19 SET TT=TT+1
+20 IF TT=11
SET JJ=JJ+1
+21 SET PID="P"_JJ_TT
+22 DO P1(PID)
+23 IF TT=13
IF JJ'=7
SET TT=10
End DoDot:1
IF JJ=7&(TT=13)!(IEN>$PIECE(^DPT(0),U,3))
QUIT
+24 QUIT
+25 ;-----
P1(PID) ;PROCESS EACH PATIENT
+1 ;S PID="P"_JJ_TT
+2 SET YY=^BYIMTMP("MU2","DATA",PID)
+3 SET ZZ=""
+4 IF $EXTRACT(PID,1,3)="P11"
SET L2=PID_2
SET ZZ=^BYIMTMP("MU2","DATA",L2)
+5 KILL DA,DR,DIE
+6 SET DR=$PIECE(YY,";",3)
+7 SET DR=$TRANSLATE(DR,"|",";")
+8 SET NET=$PIECE($PIECE(YY,"1802////",2),";")
+9 SET NAM=$PIECE($PIECE(DR,".01////",2),";")
+10 SET DR=$PIECE(DR,";",2,99)
+11 IF 0
IF $DATA(^DPT("B",NAM,IEN))
Begin DoDot:1
+12 IF TT=11
SET JJ=JJ-1
+13 SET TT=TT-1
End DoDot:1
QUIT
+14 DO NCLEAN(NAM,IEN)
+15 MERGE ^BYIMTMP("RESTORE","DPT",IEN)=^DPT(IEN)
+16 MERGE ^BYIMTMP("RESTORE","AUPNPAT",IEN)=^AUPNPAT(IEN)
+17 WRITE !,$JUSTIFY(IEN,6),?8,NAM,"..."
HANG 1
+18 SET DA=IEN
+19 SET DIE="^DPT("
+20 DO ^DIE
+21 IF ZZ]""
Begin DoDot:1
+22 SET DA=IEN
+23 SET DIE="^DPT("
+24 SET DR=$PIECE(ZZ,";",3)
+25 SET DR=$TRANSLATE(DR,"|",";")
+26 DO ^DIE
End DoDot:1
+27 SET ^BYIMTMP("MU2","PAT",PID)=DA
+28 SET $PIECE(^BIP(DA,0),U)=DA
+29 SET $PIECE(^BIP(DA,0),U,8)=""
+30 SET $PIECE(^BIP(DA,0),U,16)=""
+31 SET $PIECE(^BIP(DA,0),U,21)=$PIECE(^DPT(DA,0),U,3)
+32 SET $PIECE(^BIP(DA,0),U,24)=1
+33 SET $PIECE(^BIP(DA,0),U,25)=DT
+34 KILL ^DPT(DA,.35)
+35 IF NET]""
SET $PIECE(^AUPNPAT(DA,18),U,2)=NET
+36 DO VISIT(DA,PID)
+37 QUIT
+38 ;-----
VISIT(DFN,PID) ;SETUP VISIT DATA
+1 NEW X,Y,Z
+2 SET NUM=$EXTRACT(PID,2)
+3 IF NUM=7
DO V7(DFN,PID)
QUIT
+4 SET ID=$EXTRACT(PID,2,5)
+5 SET LOS="T"_$EXTRACT(PID,2,5)
+6 SET VID="V"_ID
+7 SET IID="I"_ID
+8 SET BIP="BIP"_ID
+9 SET REF="REF"_ID
+10 SET BIPC="BIPC"_ID
+11 IF NUM'=5
KILL ^AUPNPREF("AC",DFN)
+12 IF NUM'=6
KILL ^BIPC("B",DFN)
+13 SET X=0
+14 FOR
SET X=$ORDER(^AUPNVIMM("AC",DFN,X))
IF 'X
QUIT
SET ^BYIMEXP("D",X)=""
SET VIMM=X
+15 IF NUM<5
KILL ^BYIMEXP("D",VIMM)
+16 SET VSIT=$PIECE(^AUPNVIMM(VIMM,0),U,3)
+17 KILL DA,DR,DIE
+18 SET DA=VSIT
+19 SET DR=$PIECE(^BYIMTMP("MU2","DATA",VID),";",3)
+20 SET DR=$TRANSLATE(DR,"|",";")
+21 IF DR]""
Begin DoDot:1
+22 MERGE ^BYIMTMP("RESTORE","DPT",DFN,"VSIT",DA)=^AUPNVSIT(DA)
+23 SET DIE="^AUPNVSIT("
+24 DO ^DIE
+25 KILL DA,DR,DIE
End DoDot:1
+26 KILL DA,DR,DIE
+27 SET DA=VIMM
+28 SET DR=$PIECE(^BYIMTMP("MU2","DATA",IID),";",3)
+29 SET DR=$TRANSLATE(DR,"|",";")
+30 IF DR["P1202"
Begin DoDot:1
+31 SET P1202=^BYIMTMP("MU2","PRV",1202)
+32 SET P1204=^BYIMTMP("MU2","PRV",1204)
+33 SET P1214=^BYIMTMP("MU2","PRV",1214)
+34 SET DR=$PIECE(DR,"P1202")_P1202_$PIECE(DR,"P1202",2)
+35 SET DR=$PIECE(DR,"P1204")_P1204_$PIECE(DR,"P1204",2)
+36 SET DR=$PIECE(DR,"P1214")_P1214_$PIECE(DR,"P1214",2)
End DoDot:1
+37 IF LOS]""
SET LOT=$GET(^BYIMTMP("MU2","LOT",LOS))
+38 IF LOT
IF DR[LOS
SET DR=$PIECE(DR,LOS)_LOT_$PIECE(DR,LOS,2)
+39 SET DIE="^AUPNVIMM("
+40 MERGE ^BYIMTMP("RESTORE","DPT",DFN,"VIMM",DA)=^AUPNVIMM(DA)
+41 IF DR]""
DO ^DIE
+42 KILL DA,DR,DIE
+43 IF NUM=4
DO BIP
+44 ;-----
+45 IF NUM=5
DO REF
+46 ;-----
+47 IF NUM=6
DO BIPC
+48 ;-----
+49 QUIT
+50 ;-----
BIP ;
+1 KILL DA,DR,DIE
+2 SET DA=DFN
+3 SET DR=$PIECE(^BYIMTMP("MU2","DATA",BIP),";",3)
+4 SET DR=$TRANSLATE(DR,"|",";")
+5 SET DIE="^BIP("
+6 DO ^DIE
+7 KILL DA,DR,DIE
+8 QUIT
+9 ;-----
REF ;
+1 KILL DA,DR,DIE
+2 SET DA=$ORDER(^AUPNPREF("AC",DFN,0))
+3 IF 'DA
Begin DoDot:1
+4 SET X=3
+5 SET DIC="^AUPNPREF("
+6 SET DIC(0)="L"
+7 SET DIC("DR")=".02////"_DFN
+8 DO FILE^DICN
+9 SET DA=+Y
End DoDot:1
+10 KILL ^BYIMEXP("REF",DA)
+11 SET DR=$PIECE(^BYIMTMP("MU2","DATA",REF),";",3)
+12 SET DR=$TRANSLATE(DR,"|",";")
+13 SET DR=$PIECE(DR,"DFN")_DFN_$PIECE(DR,"DFN",2)
+14 SET DIE="^AUPNPREF("
+15 DO ^DIE
+16 KILL DA,DR,DIE
+17 QUIT
+18 ;-----
BIPC ;
+1 KILL DA,DR,DIE
+2 SET DA=$ORDER(^BIPC("B",DFN,0))
+3 IF 'DA
Begin DoDot:1
+4 SET X=DFN
+5 SET DIC="^BIPC("
+6 SET DIC(0)="L"
+7 SET DIR("DR")=".02////132"
+8 DO FILE^DICN
+9 KILL DIC
+10 SET DA=+Y
End DoDot:1
+11 KILL ^BYIMEXP("HXV",DA)
+12 SET DR=$PIECE(^BYIMTMP("MU2","DATA",BIPC),";",3)
+13 SET DR=$TRANSLATE(DR,"|",";")
+14 SET DR=$PIECE(DR,"DFN")_DFN_$PIECE(DR,"DFN",2)
+15 SET DIE="^BIPC("
+16 DO ^DIE
+17 KILL DA,DR,DIE
+18 QUIT
+19 ;-----
SEND ;EP;SEND RT VXU MU2 MESSAGES
+1 ;D WARN
+2 NEW BYIMMU2
+3 SET BYIMMU2=1
+4 IF $GET(BYIMQUIT)
KILL BYIMQUIT
QUIT
+5 WRITE !!,"Please stand by while I create and send the NIST messages...",!
+6 SET SCN=""
+7 FOR
SET SCN=$ORDER(^BYIMTMP("MU2","PAT",SCN))
IF SCN=""
QUIT
SET DFN=^(SCN)
Begin DoDot:1
+8 SET RT="VXU"
+9 ;PATCH 8 CR 08626 - SEND ONLY ADMINISTERED IMMS
+10 SET BYIMALL=1
+11 ;PATCH 8 CR 08626 END
+12 DO VXU^BYIMRT(DFN)
End DoDot:1
+13 HANG 30
+14 ;D RESTORE
+15 QUIT
+16 ;-----
V7(DFN,PID) ;SETUP VISIT DATA
+1 KILL ^BYIMTMP("MU2","V7")
+2 NEW X,Y,Z
+3 SET NUM=7
+4 SET ID=$EXTRACT(PID,2,5)
+5 SET LOS="T"_$EXTRACT(PID,2,5)
+6 SET VID="V"_ID
+7 SET IID="I"_ID
+8 KILL ^AUPNPREF("AC",DFN)
+9 KILL ^BIPC("B",DFN)
+10 SET CNT=1
+11 SET X=0
+12 FOR
SET X=$ORDER(^AUPNVIMM("AC",DFN,X))
IF 'X
QUIT
Begin DoDot:1
+13 SET ^BYIMEXP("D",X)=""
+14 SET V=$PIECE($GET(^AUPNVIMM(X,0)),U,3)
+15 IF CNT<4
IF '$DATA(^BYIMTMP("MU2","V7",V))
Begin DoDot:2
+16 SET TMP(CNT)=V_U_X
+17 SET CNT=CNT+1
+18 KILL ^BYIMEXP("D",X)
+19 SET ^BYIMTMP("MU2","V7",V)=""
End DoDot:2
End DoDot:1
+20 DO P7(DFN,PID,.TMP)
+21 QUIT
+22 ;-----
P7(DFN,PID,TMP) ;PROCESS SCENARIO 7 VISITS
+1 NEW CNT
+2 SET CNT=0
+3 FOR CNT=1,2,3
SET X=TMP(CNT)
Begin DoDot:1
+4 SET VSIT=+X
+5 IF 'VSIT
QUIT
+6 SET VIMM=$PIECE(X,U,2)
+7 KILL ^BYIMEXP("D",VIMM)
+8 SET ^BYIMTMP("MU2","V7",VSIT)=""
+9 IF CNT>1
Begin DoDot:2
+10 SET VID=$EXTRACT(VID,1,4)_CNT
+11 SET IID=$EXTRACT(IID,1,4)_CNT
End DoDot:2
+12 SET (LOS,LOT)=""
+13 IF CNT=1
SET LOS="T"_$EXTRACT(PID,2,4)
+14 IF CNT=3
SET LOS="T"_$EXTRACT(PID,2,4)_3
+15 KILL DA,DR,DIE
+16 SET DA=VSIT
+17 SET DR=$PIECE(^BYIMTMP("MU2","DATA",VID),";",3)
+18 SET DR=$TRANSLATE(DR,"|",";")
+19 MERGE ^BYIMTMP("RESTORE","DPT",DFN,"VSIT",DA)=^AUPNVSIT(DA)
+20 SET DIE="^AUPNVSIT("
+21 DO ^DIE
+22 KILL DA,DR,DIE
+23 SET DA=VIMM
+24 SET DR=$PIECE(^BYIMTMP("MU2","DATA",IID),";",3)
+25 SET DR=$TRANSLATE(DR,"|",";")
+26 IF LOS]""
SET LOT=$GET(^BYIMTMP("MU2","LOT",LOS))
+27 IF LOT
IF DR[LOS
SET DR=$PIECE(DR,LOS)_LOT_$PIECE(DR,LOS,2)
+28 IF DR["P1202"
Begin DoDot:2
+29 SET P1202=^BYIMTMP("MU2","PRV",1202)
+30 SET P1204=^BYIMTMP("MU2","PRV",1204)
+31 SET P1214=^BYIMTMP("MU2","PRV",1214)
+32 SET DR=$PIECE(DR,"P1202")_P1202_$PIECE(DR,"P1202",2)
+33 SET DR=$PIECE(DR,"P1204")_P1204_$PIECE(DR,"P1204",2)
+34 SET DR=$PIECE(DR,"P1214")_P1214_$PIECE(DR,"P1214",2)
End DoDot:2
+35 SET DIE="^AUPNVIMM("
+36 MERGE ^BYIMTMP("RESTORE","DPT",DFN,"VIMM",DA)=^AUPNVIMM(DA)
+37 DO ^DIE
+38 KILL DA,DR,DIE
End DoDot:1
+39 KILL ^BYIMTMP("MU2","V7",VSIT)
+40 QUIT
+41 ;-----
NCLEAN(NAM,IEN) ;CLEAN 'B' XREF
+1 SET ^DPT("B",NAM,IEN)=""
+2 NEW X,Y,Z
+3 SET X=0
+4 FOR
SET X=$ORDER(^DPT("B",NAM,X))
IF 'X
QUIT
IF X'=IEN
KILL ^DPT("B",NAM,X)
+5 QUIT
+6 ;-----
RESTORE ;RESTORE ORIGINAL DPT AND AUPNPAT CONTENT
+1 QUIT
WRITE !!,"Please stand by while I restore the pre-NIST environment...",!
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^BYIMTMP("RESTORE","AUPNPAT",DFN))
IF 'DFN
QUIT
DO R1(DFN)
RPRV SET PRV=0
+1 FOR
SET PRV=$ORDER(^BYIMTMP("RESTORE","PRV",PRV))
IF 'PRV
QUIT
Begin DoDot:1
+2 MERGE ^VA(200,PRV)=^BYIMTMP("RESTORE","PRV",PRV)
+3 KILL DA,DIK
+4 SET DA=PRV
+5 SET DIK="^VA(200,"
+6 DO IX1^DIK
+7 KILL DA,DIK
End DoDot:1
RIML SET IML=0
+1 FOR
SET IML=$ORDER(^BYIMTMP("RESTORE","IML",IML))
IF 'IML
QUIT
Begin DoDot:1
+2 MERGE ^AUTTIML(IML)=^BYIMTMP("RESTORE","IML",IML)
+3 KILL DA,DIK
+4 SET DA=IML
+5 SET DIK="^AUTTIML("
+6 DO IX1^DIK
+7 KILL DA,DIK
End DoDot:1
RIMM SET IMM=0
+1 FOR
SET IMM=$ORDER(^BYIMTMP("RESTORE","IMM",IMM))
IF 'IMM
QUIT
Begin DoDot:1
+2 MERGE ^AUTTIMM(IMM)=^BYIMTMP("RESTORE","IMM",IMM)
+3 KILL DA,DIK
+4 SET DA=IMM
+5 SET DIK="^AUTTIMM("
+6 DO IX1^DIK
+7 KILL DA,DIK
End DoDot:1
+8 SET X=0
+9 FOR
SET X=$ORDER(^BYIMTMP("RESTORE","AUPNPAT",X))
IF 'X
QUIT
IF $DATA(^AUPNPAT(X,0))
KILL ^BYIMTMP("RESTORE","AUPNPAT",X)
+10 IF $ORDER(^BYIMTMP("RESTORE","AUPNPAT",0))
WRITE !!,"AUPNPAT... Pending"
+11 IF '$TEST
KILL ^BYIMTMP("RESTORE")
+12 WRITE !!,"Database RESTORE process complete."
+13 DO PAUSE^BYIMIMM6
+14 QUIT
+15 ;-----
R1(DFN) ;DO RESTORE
+1 MERGE ^AUPNPAT(DFN)=^BYIMTMP("RESTORE","AUPNPAT",DFN)
+2 KILL DA,DIK
+3 SET DA=DFN
+4 SET DIK="^AUPNPAT("
+5 DO IX1^DIK
+6 KILL DA,DIK
+7 MERGE ^DPT(DFN)=^BYIMTMP("RESTORE","DPT",DFN)
+8 SET DA=DFN
+9 SET DIK="^DPT("
+10 DO IX1^DIK
+11 KILL DA,DIK
VSIT SET VSIT=0
+1 FOR
SET VSIT=$ORDER(^BYIMTMP("RESTORE","DPT",DFN,"VSIT",VSIT))
IF 'VSIT
QUIT
Begin DoDot:1
+2 MERGE ^AUPNVSIT(VSIT)=^BYIMTMP("MU2","DPT",DFN,"VSIT",VSIT)
+3 KILL DA,DIK
+4 SET DA=VSIT
+5 SET DIK="^AUPNVSIT("
+6 DO IX1^DIK
+7 KILL DA,DIK
End DoDot:1
VIMM SET VIMM=0
+1 FOR
SET VIMM=$ORDER(^BYIMTMP("RESTORE","DPT",DFN,"VIMM",VIMM))
IF 'VIMM
QUIT
Begin DoDot:1
+2 MERGE ^AUPNVIMM(VIMM)=^BYIMTMP("RESTORE","DPT",DFN,"VIMM",VIMM)
+3 KILL DA,DIK
+4 SET DA=VIMM
+5 SET DIK="^AUPNVIMM("
+6 DO IX1^DIK
+7 KILL DA,DIK
End DoDot:1
+8 QUIT
+9 ;-----
WARN ;CHECK FOR TEST DATABASE
+1 WRITE @IOF
+2 WRITE !?10,"Warning - Warning - Warning"
+3 WRITE !!?10,"The BYIM automated NIST Process - PREP, SEND and RESTORE"
+4 WRITE !?10,"can only be run on a test database, never on a production database"
+5 KILL DIR
+6 SET DIR(0)="YO"
+7 SET DIR("A")="Do you certify that this is a TEST database"
+8 SET DIR("B")="NO"
+9 WRITE !
+10 DO ^DIR
+11 KILL DIR
+12 IF Y'=1
Begin DoDot:1
+13 SET BYIMQUIT=1
+14 WRITE !!,"Please run the BYIM automated NIST Process on a test database"
+15 HANG 4
End DoDot:1
QUIT
+16 QUIT
+17 ;-----
MPAT ;EP;SETUP MASTER DB PATIENTS
+1 DO MU21^BYIMMU21
+2 SET PID=""
+3 FOR
SET PID=$ORDER(^BYIMTMP("PAT",PID))
IF PID=""
QUIT
SET IEN=^(PID)
SET JJ=$EXTRACT(PID,2)
SET TT=$EXTRACT(PID,2,3)
DO P1(PID)
+4 QUIT
MSEND DO SEND
+1 QUIT
+2 ;-----
