ACDVIMP1 ;IHS/ADC/EDE/KML - BUILD CDMIS ENTRIES FROM IMPORTED GLOBAL;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;;
;******************************************************************
;Build CDMIS data files on area/HQ machine from the ^ACDVTMP global
;that has just been imported to the area/HQ machine
;****************************************************************
EN ;EP
;//^ACDVIMP
;Check for existence of data
I '$D(^ACDVTMP) W !,"No data to import..." Q
;
;Validate incomming ASUFAC's are in the area location file
;ACDUSER is in the form 'DUZ(2)^PROGRAM ASSOCIATED WITH VISIT'
;Phoenix may have several programs in their database because they
;will have outlying facilities dialing in to use CDMIS.
;
W !! K ACDQUIT S ACDUSER="" F S ACDUSER=$O(^ACDVTMP(ACDUSER)) Q:ACDUSER="" W !,"Checking for the existence of ASUFAC: ",$P(ACDUSER,"*",2)," in your location file." I '$O(^AUTTLOC("C",$P(ACDUSER,"*",2),0)) S ACDQUIT=1 W *7," Missing.",!
I $D(ACDQUIT) W !!,"Aborted...Contact your site manager immediately.." S ^ACDV1TMP=1 Q
E W !!,"All facility codes exist. Proceeding with rebuild...",!
;
S ACDUSER="" F S ACDUSER=$O(^ACDVTMP(ACDUSER)) Q:ACDUSER="" F ACDV=0:0 S ACDV=$O(^ACDVTMP(ACDUSER,ACDV)) Q:'ACDV D:$D(^(ACDV,"P")) L I $D(^ACDVTMP(ACDUSER,ACDV,"V")) S ACD("V")=^("V") D FILEV,L W "."
I $D(^ACDV1TMP) W !!,"Since this import is finished, now killing the ^ACDV1TMP global flag." K ^ACDV1TMP ; kill of scratch global SAC EXEMPTION (2.3.2.3 killing of unsubscripted globals is prohibited)
Q
L ;Get data from link files
I $D(^ACDVTMP(ACDUSER,ACDV,"P")) D P Q
I $D(^ACDVTMP(ACDUSER,ACDV,"IIF")) D IIF Q
I $D(^ACDVTMP(ACDUSER,ACDV,"TDC")) D TDC Q
I $D(^ACDVTMP(ACDUSER,ACDV,"CS")) D CS Q
Q
IIF ;Get entry to file into ^ACDIIF
F ACDDA=0:0 S ACDDA=$O(^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA)) Q:'ACDDA S ACD("IIF")=^(ACDDA) D FILEIIF
Q
TDC ;Get entry to file into ^ACDTDC
F ACDDA=0:0 S ACDDA=$O(^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA)) Q:'ACDDA S ACD("TDC")=^(ACDDA) D FILETDC
Q
CS ;Get entry to file into ^ACDCS
F ACDDA=0:0 S ACDDA=$O(^ACDVTMP(ACDUSER,ACDV,"CS",ACDDA)) Q:'ACDDA S ACD("CS")=^(ACDDA) D FILECS
Q
P ;Get entry to file into ^ACDPD
S ACD("P")=^ACDVTMP(ACDUSER,ACDV,"P") D FILEP
Q
FILEIIF ;File entry into ^ACDIIF
S DIC="^ACDIIF(",X=$P(ACD("IIF"),U),DIC(0)="L" D FILE^ACDFMC
S ^ACDIIF(+Y,0)=ACD("IIF"),^("BWP")=ACDBWP
S ACDIIF=+Y
F ACDMULT=2,3 F ACDMLEV=0:0 S ACDMLEV=$O(^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,$S(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV)) Q:'ACDMLEV D
.S DA(1)=ACDIIF,DIC="^ACDIIF("_DA(1)_","_ACDMULT_",",DIC(0)="L",X=ACDMLEV S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002170."_$S(ACDMULT=2:"05",1:"01")_"PA" D FILE^ACDFMC
.K ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,$S(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV)
S DA=ACDIIF,DIK="^ACDIIF(" D IX1^DIK
K ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA)
Q
FILETDC ;File entry into ^ACDTDC
S DIC="^ACDTDC(",X=$P(ACD("TDC"),U),DIC(0)="L" D FILE^ACDFMC
S ^ACDTDC(+Y,0)=ACD("TDC"),^("BWP")=ACDBWP
S ACDTDC=+Y
F ACDMULT=2,3 F ACDMLEV=0:0 S ACDMLEV=$O(^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,$S(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV)) Q:'ACDMLEV D
.S DA(1)=ACDTDC,DIC="^ACDTDC("_DA(1)_","_ACDMULT_",",DIC(0)="L",X=ACDMLEV S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002171."_$S(ACDMULT=2:"02",1:"0102")_"PA" D FILE^ACDFMC
.K ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,$S(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV)
S DA=ACDTDC,DIK="^ACDTDC(" D IX1^DIK
K ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA)
Q
FILECS ;File entry into ^ACDCS
S DIC="^ACDCS(",X=$P(ACD("CS"),U),DIC(0)="L" D FILE^ACDFMC
S ^ACDCS(+Y,0)=ACD("CS"),^("BWP")=ACDBWP
S ACDCS=+Y
K ^ACDVTMP(ACDUSER,ACDV,"CS",ACDDA)
S DA=ACDCS,DIK="^ACDCS(" D IX1^DIK
Q
FILEV ;File visit into ^ACDVIS
S DIC="^ACDVIS(",X=$P(ACD("V"),U),DIC(0)="L" D FILE^ACDFMC
S ^ACDVIS(+Y,0)=ACD("V")
S ACDBWP=+Y
S ACDPG=$O(^AUTTLOC("C",$P(ACDUSER,"*",2),0))
I '$D(^ACDF5PI(ACDPG,0)) S DIC="^ACDF5PI(",DIC(0)="L",X=ACDPG,DINUM=X D FILE^ACDFMC
S DIE="^ACDVIS(",DA=ACDBWP,DR="99.99///^S X=ACDPG" D DIE^ACDFMC
S DA=ACDBWP,DIK="^ACDVIS(" D IX1^DIK
K ^ACDVTMP(ACDUSER,ACDV,"V")
Q
FILEP ;File entry into ^ACDPD
S DIC="^ACDPD(",X=$P(ACD("P"),U),DIC(0)="L" D FILE^ACDFMC
S ^ACDPD(+Y,0)=ACD("P")
S ACDP=+Y
S ACDPG=$O(^AUTTLOC("C",$P(ACDUSER,"*",2),0))
I '$D(^ACDF5PI(ACDPG,0)) S DIC="^ACDF5PI(",DIC(0)="L",X=ACDPG,DINUM=X D FILE^ACDFMC
S DIE="^ACDPD(",DA=ACDP,DR="3///^S X=ACDPG" D DIE^ACDFMC
F ACDAY=0:0 S ACDAY=$O(^ACDVTMP(ACDUSER,ACDV,"P","DAY",ACDAY)) Q:'ACDAY S ACD("P")=^(ACDAY) D
.S DA(1)=ACDP,DIC="^ACDPD("_DA(1)_",1,",DIC(0)="L",X=ACDAY S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002170.75A" D FILE^ACDFMC S ^ACDPD(ACDP,1,+Y,0)=ACD("P")
.K ^ACDVTMP(ACDUSER,ACDV,"P","DAY",ACDAY)
S DA=ACDP,DIK="^ACDPD(" D IX1^DIK
K ^ACDVTMP(ACDUSER,ACDV,"P")
Q
ACDVIMP1 ;IHS/ADC/EDE/KML - BUILD CDMIS ENTRIES FROM IMPORTED GLOBAL;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;;
+3 ;******************************************************************
+4 ;Build CDMIS data files on area/HQ machine from the ^ACDVTMP global
+5 ;that has just been imported to the area/HQ machine
+6 ;****************************************************************
EN ;EP
+1 ;//^ACDVIMP
+2 ;Check for existence of data
+3 IF '$DATA(^ACDVTMP)
WRITE !,"No data to import..."
QUIT
+4 ;
+5 ;Validate incomming ASUFAC's are in the area location file
+6 ;ACDUSER is in the form 'DUZ(2)^PROGRAM ASSOCIATED WITH VISIT'
+7 ;Phoenix may have several programs in their database because they
+8 ;will have outlying facilities dialing in to use CDMIS.
+9 ;
+10 WRITE !!
KILL ACDQUIT
SET ACDUSER=""
FOR
SET ACDUSER=$ORDER(^ACDVTMP(ACDUSER))
IF ACDUSER=""
QUIT
WRITE !,"Checking for the existence of ASUFAC: ",$PIECE(ACDUSER,"*",2)," in your location file."
IF '$ORDER(^AUTTLOC("C",$PIECE(ACDUSER,"*",2),0))
SET ACDQUIT=1
WRITE *7," Missing.",!
+11 IF $DATA(ACDQUIT)
WRITE !!,"Aborted...Contact your site manager immediately.."
SET ^ACDV1TMP=1
QUIT
+12 IF '$TEST
WRITE !!,"All facility codes exist. Proceeding with rebuild...",!
+13 ;
+14 SET ACDUSER=""
FOR
SET ACDUSER=$ORDER(^ACDVTMP(ACDUSER))
IF ACDUSER=""
QUIT
FOR ACDV=0:0
SET ACDV=$ORDER(^ACDVTMP(ACDUSER,ACDV))
IF 'ACDV
QUIT
IF $DATA(^(ACDV,"P"))
DO L
IF $DATA(^ACDVTMP(ACDUSER,ACDV,"V"))
SET ACD("V")=^("V")
DO FILEV
DO L
WRITE "."
+15 ; kill of scratch global SAC EXEMPTION (2.3.2.3 killing of unsubscripted globals is prohibited)
IF $DATA(^ACDV1TMP)
WRITE !!,"Since this import is finished, now killing the ^ACDV1TMP global flag."
KILL ^ACDV1TMP
+16 QUIT
L ;Get data from link files
+1 IF $DATA(^ACDVTMP(ACDUSER,ACDV,"P"))
DO P
QUIT
+2 IF $DATA(^ACDVTMP(ACDUSER,ACDV,"IIF"))
DO IIF
QUIT
+3 IF $DATA(^ACDVTMP(ACDUSER,ACDV,"TDC"))
DO TDC
QUIT
+4 IF $DATA(^ACDVTMP(ACDUSER,ACDV,"CS"))
DO CS
QUIT
+5 QUIT
IIF ;Get entry to file into ^ACDIIF
+1 FOR ACDDA=0:0
SET ACDDA=$ORDER(^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA))
IF 'ACDDA
QUIT
SET ACD("IIF")=^(ACDDA)
DO FILEIIF
+2 QUIT
TDC ;Get entry to file into ^ACDTDC
+1 FOR ACDDA=0:0
SET ACDDA=$ORDER(^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA))
IF 'ACDDA
QUIT
SET ACD("TDC")=^(ACDDA)
DO FILETDC
+2 QUIT
CS ;Get entry to file into ^ACDCS
+1 FOR ACDDA=0:0
SET ACDDA=$ORDER(^ACDVTMP(ACDUSER,ACDV,"CS",ACDDA))
IF 'ACDDA
QUIT
SET ACD("CS")=^(ACDDA)
DO FILECS
+2 QUIT
P ;Get entry to file into ^ACDPD
+1 SET ACD("P")=^ACDVTMP(ACDUSER,ACDV,"P")
DO FILEP
+2 QUIT
FILEIIF ;File entry into ^ACDIIF
+1 SET DIC="^ACDIIF("
SET X=$PIECE(ACD("IIF"),U)
SET DIC(0)="L"
DO FILE^ACDFMC
+2 SET ^ACDIIF(+Y,0)=ACD("IIF")
SET ^("BWP")=ACDBWP
+3 SET ACDIIF=+Y
+4 FOR ACDMULT=2,3
FOR ACDMLEV=0:0
SET ACDMLEV=$ORDER(^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,$SELECT(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV))
IF 'ACDMLEV
QUIT
Begin DoDot:1
+5 SET DA(1)=ACDIIF
SET DIC="^ACDIIF("_DA(1)_","_ACDMULT_","
SET DIC(0)="L"
SET X=ACDMLEV
IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^9002170."_$SELECT(ACDMULT=2:"05",1:"01")_"PA"
DO FILE^ACDFMC
+6 KILL ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,$SELECT(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV)
End DoDot:1
+7 SET DA=ACDIIF
SET DIK="^ACDIIF("
DO IX1^DIK
+8 KILL ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA)
+9 QUIT
FILETDC ;File entry into ^ACDTDC
+1 SET DIC="^ACDTDC("
SET X=$PIECE(ACD("TDC"),U)
SET DIC(0)="L"
DO FILE^ACDFMC
+2 SET ^ACDTDC(+Y,0)=ACD("TDC")
SET ^("BWP")=ACDBWP
+3 SET ACDTDC=+Y
+4 FOR ACDMULT=2,3
FOR ACDMLEV=0:0
SET ACDMLEV=$ORDER(^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,$SELECT(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV))
IF 'ACDMLEV
QUIT
Begin DoDot:1
+5 SET DA(1)=ACDTDC
SET DIC="^ACDTDC("_DA(1)_","_ACDMULT_","
SET DIC(0)="L"
SET X=ACDMLEV
IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^9002171."_$SELECT(ACDMULT=2:"02",1:"0102")_"PA"
DO FILE^ACDFMC
+6 KILL ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,$SELECT(ACDMULT=2:"DRUG",1:"SECPROB"),ACDMLEV)
End DoDot:1
+7 SET DA=ACDTDC
SET DIK="^ACDTDC("
DO IX1^DIK
+8 KILL ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA)
+9 QUIT
FILECS ;File entry into ^ACDCS
+1 SET DIC="^ACDCS("
SET X=$PIECE(ACD("CS"),U)
SET DIC(0)="L"
DO FILE^ACDFMC
+2 SET ^ACDCS(+Y,0)=ACD("CS")
SET ^("BWP")=ACDBWP
+3 SET ACDCS=+Y
+4 KILL ^ACDVTMP(ACDUSER,ACDV,"CS",ACDDA)
+5 SET DA=ACDCS
SET DIK="^ACDCS("
DO IX1^DIK
+6 QUIT
FILEV ;File visit into ^ACDVIS
+1 SET DIC="^ACDVIS("
SET X=$PIECE(ACD("V"),U)
SET DIC(0)="L"
DO FILE^ACDFMC
+2 SET ^ACDVIS(+Y,0)=ACD("V")
+3 SET ACDBWP=+Y
+4 SET ACDPG=$ORDER(^AUTTLOC("C",$PIECE(ACDUSER,"*",2),0))
+5 IF '$DATA(^ACDF5PI(ACDPG,0))
SET DIC="^ACDF5PI("
SET DIC(0)="L"
SET X=ACDPG
SET DINUM=X
DO FILE^ACDFMC
+6 SET DIE="^ACDVIS("
SET DA=ACDBWP
SET DR="99.99///^S X=ACDPG"
DO DIE^ACDFMC
+7 SET DA=ACDBWP
SET DIK="^ACDVIS("
DO IX1^DIK
+8 KILL ^ACDVTMP(ACDUSER,ACDV,"V")
+9 QUIT
FILEP ;File entry into ^ACDPD
+1 SET DIC="^ACDPD("
SET X=$PIECE(ACD("P"),U)
SET DIC(0)="L"
DO FILE^ACDFMC
+2 SET ^ACDPD(+Y,0)=ACD("P")
+3 SET ACDP=+Y
+4 SET ACDPG=$ORDER(^AUTTLOC("C",$PIECE(ACDUSER,"*",2),0))
+5 IF '$DATA(^ACDF5PI(ACDPG,0))
SET DIC="^ACDF5PI("
SET DIC(0)="L"
SET X=ACDPG
SET DINUM=X
DO FILE^ACDFMC
+6 SET DIE="^ACDPD("
SET DA=ACDP
SET DR="3///^S X=ACDPG"
DO DIE^ACDFMC
+7 FOR ACDAY=0:0
SET ACDAY=$ORDER(^ACDVTMP(ACDUSER,ACDV,"P","DAY",ACDAY))
IF 'ACDAY
QUIT
SET ACD("P")=^(ACDAY)
Begin DoDot:1
+8 SET DA(1)=ACDP
SET DIC="^ACDPD("_DA(1)_",1,"
SET DIC(0)="L"
SET X=ACDAY
IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^9002170.75A"
DO FILE^ACDFMC
SET ^ACDPD(ACDP,1,+Y,0)=ACD("P")
+9 KILL ^ACDVTMP(ACDUSER,ACDV,"P","DAY",ACDAY)
End DoDot:1
+10 SET DA=ACDP
SET DIK="^ACDPD("
DO IX1^DIK
+11 KILL ^ACDVTMP(ACDUSER,ACDV,"P")
+12 QUIT
