- 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 ;-----