ACDVSAVE ;IHS/ADC/EDE/KML - EXTRACT VISIT DATA;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
;
EN ;EP
;//[ACD RE-EXT]
;Options locked
D EN^ACDGLOCK
;
;Chk for incomplete import.
I $D(^ACDV1TMP) W !!,*7,*7,"Data still exists in the ^ACDV1TMP global due to a",!,"CORRUPT LOCATION FILE. * I MUST STOP *" D K Q
;
;
I $D(^ACDVTMP) W !!,*7,*7,"An extract is presently running." D K Q
K ^ACDVTMP ; kill of scratch global SAC EXEMPTION (2.3.2.3 killing of unsubscripted globals is prohibited)
;
W !!,*7,*7,"Once a CDMIS DATA RECORD is extracted,",!,"the record may NOT be 'DELETED' or 'EDITED'."
;
D EN1^ACDV4MES
I $E(ACD6DIG)="9" W !!,"OK, Headquarters is Archiving",!!,"Be sure to delete the data when the archive is finished."
;
D ;Ask start/stop date
K ACDQUIT D D^ACDWRQ I $D(ACDQUIT) D K Q
S ACDDTF=ACDFR,ACDDTT=ACDTO
;
W !!,"Extracting all CDMIS visit/prevention data",!,"from: ",$$DD^ACDFUNC(ACDFR)," through: ",$$DD^ACDFUNC(ACDTO)
;
;
T ;Ask transmission mode
; commented out net mail option per Wilbur Woodis
;K ACDMAIL S DIR(0)="S^1:TRANSMIT DATA VIA HOST OS FILE;2:TRANSMIT DATA VIA NET MAIL" D ^DIR G:X["^"!($D(DTOUT)!(X="")) K
;I Y=2 S ACDMAIL=1 D
;.I '$O(^ACDOMAIN(DUZ(2),1,0)) W !!,*7,*7,"You must set domains to send extracted data to." D EN^ACDSRV3
;.S ACDSRVOP=2 D DOM^ACDSRV3 I '$D(XMY) W !!,*7,*7,"No domains are defined to send the extraction data to.",!,"I cannot continue because of this." S ACDQUIT=1
;I $D(ACDQUIT) D K Q
F W !!,"OK to continue" S %=2 D YN^DICN W:%=0 " Answer Yes or No" G:%'=1&(%'=0) K Q:%=1
;
;Clean up incomplete entries prior to extracting data.
D EN^ACDCLN
;
;Get backfilled data to export
S X1=ACDFR,X2=-600 D C^%DTC S ACDFR=X
;
W !!,"Looking for visit data to extract....."
;
VIS ;Get visits
F ACD=ACDFR-.01:0 S ACD=$O(^ACDVIS("B",ACD)) Q:'ACD!(ACD>ACDTO) F ACDV=0:0 S ACDV=$O(^ACDVIS("B",ACD,ACDV)) Q:'ACDV D V D:ACDVHIT L W "."
D CLN
;
;Get preventions
W !!,"Looking for prevention data to extract....."
F ACD=ACDFR-.01:0 S ACD=$O(^ACDPD("B",ACD)) Q:'ACD!(ACD>ACDTO) F ACDV=0:0 S ACDV=$O(^ACDPD("B",ACD,ACDV)) Q:'ACDV I $D(^ACDPD(ACDV,0)) D P
;
;Create host file
I '$D(^ACDVTMP) W !!,"No new data found." G K
I '$D(ACDMAIL) S XBGL="ACDVTMP",$P(^ACDVTMP(0),U)=ACDDTT,$P(^(0),U,2)=ACDDTF,$P(^(0),U,20)="IMPORT FILE" D ^ACDGX5
;Use net mail
I $D(ACDMAIL) D ^ACDVSRV0
;
W !!,"Now deleting the ^ACDVTMP global....."
K ^ACDVTMP ; kill of scratch global SAC EXEMPTION (2.3.2.3 KILLING of unsubscripted globals is prohibited)
W !,"CDMIS data extraction successfully completed."
D PAUSE^ACDDEU
G K
;
L ;Get visit link file
F ACDDA=0:0 S ACDDA=$O(^ACDIIF("C",ACDV,ACDDA)) Q:'ACDDA I $D(^ACDIIF(ACDDA,0)) D IIF
F ACDDA=0:0 S ACDDA=$O(^ACDTDC("C",ACDV,ACDDA)) Q:'ACDDA I $D(^ACDTDC(ACDDA,0)) D TDC
F ACDDA=0:0 S ACDDA=$O(^ACDCS("C",ACDV,ACDDA)) Q:'ACDDA I $D(^ACDCS(ACDDA,0)) D CS
Q
;
IIF ;Bld node
I $P(^ACDIIF(ACDDA,0),U,25) Q
I '$D(^ACDVTMP(ACDUSER,ACDV,"V")) Q
S ACD("IIF")=^ACDIIF(ACDDA,0)
S ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA)=ACD("IIF")
F ACDRUG=0:0 S ACDRUG=$O(^ACDIIF(ACDDA,2,ACDRUG)) Q:'ACDRUG I $D(^(ACDRUG,0)) S ACDPOINT=^(0) S ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,"DRUG",ACDPOINT)=ACDPOINT
F ACDSCND=0:0 S ACDSCND=$O(^ACDIIF(ACDDA,3,ACDSCND)) Q:'ACDSCND I $D(^(ACDSCND,0)) S ACDPOINT=^(0) S ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,"SECPROB",ACDPOINT)=ACDPOINT
S DIE="^ACDIIF(",DA=ACDDA,DR="25///T" D DIE^ACDFMC
Q
TDC ;Bld node
I $P(^ACDTDC(ACDDA,0),U,25) Q
I '$D(^ACDVTMP(ACDUSER,ACDV,"V")) Q
S ACD("TDC")=^ACDTDC(ACDDA,0)
S ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA)=ACD("TDC")
F ACDRUG=0:0 S ACDRUG=$O(^ACDTDC(ACDDA,2,ACDRUG)) Q:'ACDRUG I $D(^(ACDRUG,0)) S ACDPOINT=^(0) S ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,"DRUG",ACDPOINT)=ACDPOINT
F ACDSCND=0:0 S ACDSCND=$O(^ACDTDC(ACDDA,3,ACDSCND)) Q:'ACDSCND I $D(^(ACDSCND,0)) S ACDPOINT=^(0) S ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,"SECPROB",ACDPOINT)=ACDPOINT
S DIE="^ACDTDC(",DA=ACDDA,DR="25///T" D DIE^ACDFMC
Q
CS ;Bld node
I $P(^ACDCS(ACDDA,0),U,5) Q
I '$D(^ACDVTMP(ACDUSER,ACDV,"V")) Q
S ACD("CS")=^ACDCS(ACDDA,0)
S ^ACDVTMP(ACDUSER,ACDV,"CS",ACDDA)=ACD("CS")
S DIE="^ACDCS(",DA=ACDDA,DR="5///T" D DIE^ACDFMC
Q
P ;Bld node
S ACD("P")=^ACDPD(ACDV,0)
Q:ACDPGM'=$P(ACD("P"),U,4) ; quit if not signon site
;S ACDBWP=$P(ACD("P"),U,4),ACDBWP=$P(^ACDF5PI(ACDBWP,0),U),ACDBWP=$P(^AUTTLOC(ACDBWP,0),U),ACD6PGM=$P(^AUTTLOC(ACDBWP,0),U,10)
S ACDBWP=$P(ACD("P"),U,4),ACDBWP=$P(^AUTTLOC(ACDBWP,0),U),ACD6PGM=$P(^AUTTLOC(ACDBWP,0),U,10)
S ACDUSER=$P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,10)_"*"_ACD6PGM
I $P(^ACDPD(ACDV,0),U,25) Q
S ^ACDVTMP(ACDUSER,ACDV,"P")=ACD("P")
F ACDAY=0:0 S ACDAY=$O(^ACDPD(ACDV,1,ACDAY)) Q:'ACDAY I $D(^(ACDAY,0)) S ACD("P")=^(0),^ACDVTMP(ACDUSER,ACDV,"P","DAY",ACDAY)=ACD("P")
S DIE="^ACDPD(",DA=ACDV,DR="25///T" D DIE^ACDFMC
W "."
Q
V ;V node
D V^ACDVSAV2
Q
CLN ;Make pass to clean incomplete entries
D CLN^ACDVSAV2
Q
K ;
;Unlock options
D EN1^ACDGLOCK
K ACDDTF,ACDDTT
K ACDV,ACDUSER,ACDBWP,ACDDA,ACDFR,ACDTO,ACD,ACDDRUG,ACD6PGM,ACDRUG,ACDTIME,ACDPOINT
K ACDSCND ; 3-31-95 EDE
Q
ACDVSAVE ;IHS/ADC/EDE/KML - EXTRACT VISIT DATA;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ;
EN ;EP
+1 ;//[ACD RE-EXT]
+2 ;Options locked
+3 DO EN^ACDGLOCK
+4 ;
+5 ;Chk for incomplete import.
+6 IF $DATA(^ACDV1TMP)
WRITE !!,*7,*7,"Data still exists in the ^ACDV1TMP global due to a",!,"CORRUPT LOCATION FILE. * I MUST STOP *"
DO K
QUIT
+7 ;
+8 ;
+9 IF $DATA(^ACDVTMP)
WRITE !!,*7,*7,"An extract is presently running."
DO K
QUIT
+10 ; kill of scratch global SAC EXEMPTION (2.3.2.3 killing of unsubscripted globals is prohibited)
KILL ^ACDVTMP
+11 ;
+12 WRITE !!,*7,*7,"Once a CDMIS DATA RECORD is extracted,",!,"the record may NOT be 'DELETED' or 'EDITED'."
+13 ;
+14 DO EN1^ACDV4MES
+15 IF $EXTRACT(ACD6DIG)="9"
WRITE !!,"OK, Headquarters is Archiving",!!,"Be sure to delete the data when the archive is finished."
+16 ;
D ;Ask start/stop date
+1 KILL ACDQUIT
DO D^ACDWRQ
IF $DATA(ACDQUIT)
DO K
QUIT
+2 SET ACDDTF=ACDFR
SET ACDDTT=ACDTO
+3 ;
+4 WRITE !!,"Extracting all CDMIS visit/prevention data",!,"from: ",$$DD^ACDFUNC(ACDFR)," through: ",$$DD^ACDFUNC(ACDTO)
+5 ;
+6 ;
T ;Ask transmission mode
+1 ; commented out net mail option per Wilbur Woodis
+2 ;K ACDMAIL S DIR(0)="S^1:TRANSMIT DATA VIA HOST OS FILE;2:TRANSMIT DATA VIA NET MAIL" D ^DIR G:X["^"!($D(DTOUT)!(X="")) K
+3 ;I Y=2 S ACDMAIL=1 D
+4 ;.I '$O(^ACDOMAIN(DUZ(2),1,0)) W !!,*7,*7,"You must set domains to send extracted data to." D EN^ACDSRV3
+5 ;.S ACDSRVOP=2 D DOM^ACDSRV3 I '$D(XMY) W !!,*7,*7,"No domains are defined to send the extraction data to.",!,"I cannot continue because of this." S ACDQUIT=1
+6 ;I $D(ACDQUIT) D K Q
+7 FOR
WRITE !!,"OK to continue"
SET %=2
DO YN^DICN
IF %=0
WRITE " Answer Yes or No"
IF %'=1&(%'=0)
GOTO K
IF %=1
QUIT
+8 ;
+9 ;Clean up incomplete entries prior to extracting data.
+10 DO EN^ACDCLN
+11 ;
+12 ;Get backfilled data to export
+13 SET X1=ACDFR
SET X2=-600
DO C^%DTC
SET ACDFR=X
+14 ;
+15 WRITE !!,"Looking for visit data to extract....."
+16 ;
VIS ;Get visits
+1 FOR ACD=ACDFR-.01:0
SET ACD=$ORDER(^ACDVIS("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
FOR ACDV=0:0
SET ACDV=$ORDER(^ACDVIS("B",ACD,ACDV))
IF 'ACDV
QUIT
DO V
IF ACDVHIT
DO L
WRITE "."
+2 DO CLN
+3 ;
+4 ;Get preventions
+5 WRITE !!,"Looking for prevention data to extract....."
+6 FOR ACD=ACDFR-.01:0
SET ACD=$ORDER(^ACDPD("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
FOR ACDV=0:0
SET ACDV=$ORDER(^ACDPD("B",ACD,ACDV))
IF 'ACDV
QUIT
IF $DATA(^ACDPD(ACDV,0))
DO P
+7 ;
+8 ;Create host file
+9 IF '$DATA(^ACDVTMP)
WRITE !!,"No new data found."
GOTO K
+10 IF '$DATA(ACDMAIL)
SET XBGL="ACDVTMP"
SET $PIECE(^ACDVTMP(0),U)=ACDDTT
SET $PIECE(^(0),U,2)=ACDDTF
SET $PIECE(^(0),U,20)="IMPORT FILE"
DO ^ACDGX5
+11 ;Use net mail
+12 IF $DATA(ACDMAIL)
DO ^ACDVSRV0
+13 ;
+14 WRITE !!,"Now deleting the ^ACDVTMP global....."
+15 ; kill of scratch global SAC EXEMPTION (2.3.2.3 KILLING of unsubscripted globals is prohibited)
KILL ^ACDVTMP
+16 WRITE !,"CDMIS data extraction successfully completed."
+17 DO PAUSE^ACDDEU
+18 GOTO K
+19 ;
L ;Get visit link file
+1 FOR ACDDA=0:0
SET ACDDA=$ORDER(^ACDIIF("C",ACDV,ACDDA))
IF 'ACDDA
QUIT
IF $DATA(^ACDIIF(ACDDA,0))
DO IIF
+2 FOR ACDDA=0:0
SET ACDDA=$ORDER(^ACDTDC("C",ACDV,ACDDA))
IF 'ACDDA
QUIT
IF $DATA(^ACDTDC(ACDDA,0))
DO TDC
+3 FOR ACDDA=0:0
SET ACDDA=$ORDER(^ACDCS("C",ACDV,ACDDA))
IF 'ACDDA
QUIT
IF $DATA(^ACDCS(ACDDA,0))
DO CS
+4 QUIT
+5 ;
IIF ;Bld node
+1 IF $PIECE(^ACDIIF(ACDDA,0),U,25)
QUIT
+2 IF '$DATA(^ACDVTMP(ACDUSER,ACDV,"V"))
QUIT
+3 SET ACD("IIF")=^ACDIIF(ACDDA,0)
+4 SET ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA)=ACD("IIF")
+5 FOR ACDRUG=0:0
SET ACDRUG=$ORDER(^ACDIIF(ACDDA,2,ACDRUG))
IF 'ACDRUG
QUIT
IF $DATA(^(ACDRUG,0))
SET ACDPOINT=^(0)
SET ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,"DRUG",ACDPOINT)=ACDPOINT
+6 FOR ACDSCND=0:0
SET ACDSCND=$ORDER(^ACDIIF(ACDDA,3,ACDSCND))
IF 'ACDSCND
QUIT
IF $DATA(^(ACDSCND,0))
SET ACDPOINT=^(0)
SET ^ACDVTMP(ACDUSER,ACDV,"IIF",ACDDA,"SECPROB",ACDPOINT)=ACDPOINT
+7 SET DIE="^ACDIIF("
SET DA=ACDDA
SET DR="25///T"
DO DIE^ACDFMC
+8 QUIT
TDC ;Bld node
+1 IF $PIECE(^ACDTDC(ACDDA,0),U,25)
QUIT
+2 IF '$DATA(^ACDVTMP(ACDUSER,ACDV,"V"))
QUIT
+3 SET ACD("TDC")=^ACDTDC(ACDDA,0)
+4 SET ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA)=ACD("TDC")
+5 FOR ACDRUG=0:0
SET ACDRUG=$ORDER(^ACDTDC(ACDDA,2,ACDRUG))
IF 'ACDRUG
QUIT
IF $DATA(^(ACDRUG,0))
SET ACDPOINT=^(0)
SET ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,"DRUG",ACDPOINT)=ACDPOINT
+6 FOR ACDSCND=0:0
SET ACDSCND=$ORDER(^ACDTDC(ACDDA,3,ACDSCND))
IF 'ACDSCND
QUIT
IF $DATA(^(ACDSCND,0))
SET ACDPOINT=^(0)
SET ^ACDVTMP(ACDUSER,ACDV,"TDC",ACDDA,"SECPROB",ACDPOINT)=ACDPOINT
+7 SET DIE="^ACDTDC("
SET DA=ACDDA
SET DR="25///T"
DO DIE^ACDFMC
+8 QUIT
CS ;Bld node
+1 IF $PIECE(^ACDCS(ACDDA,0),U,5)
QUIT
+2 IF '$DATA(^ACDVTMP(ACDUSER,ACDV,"V"))
QUIT
+3 SET ACD("CS")=^ACDCS(ACDDA,0)
+4 SET ^ACDVTMP(ACDUSER,ACDV,"CS",ACDDA)=ACD("CS")
+5 SET DIE="^ACDCS("
SET DA=ACDDA
SET DR="5///T"
DO DIE^ACDFMC
+6 QUIT
P ;Bld node
+1 SET ACD("P")=^ACDPD(ACDV,0)
+2 ; quit if not signon site
IF ACDPGM'=$PIECE(ACD("P"),U,4)
QUIT
+3 ;S ACDBWP">P">P">P">P">P">P">P=$P">P">P">P">P">P">P">P(ACD("P">P">P">P">P">P">P">P"),U,4),ACDBWP">P">P">P">P">P">P">P=$P">P">P">P">P">P">P">P(^ACDF5P">P">P">P">P">P">P">PI(ACDBWP">P">P">P">P">P">P">P,0),U),ACDBWP">P">P">P">P">P">P">P=$P">P">P">P">P">P">P">P(^AUTTLOC(ACDBWP">P">P">P">P">P">P">P,0),U),ACD6P">P">P">P">P">P">P">PGM=$P">P">P">P">P">P">P">P(^AUTTLOC(ACDBWP">P">P">P">P">P">P">P,0),U,10)
+4 SET ACDBWP=$PIECE(ACD("P"),U,4)
SET ACDBWP=$PIECE(^AUTTLOC(ACDBWP,0),U)
SET ACD6PGM=$PIECE(^AUTTLOC(ACDBWP,0),U,10)
+5 SET ACDUSER=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0),U,10)_"*"_ACD6PGM
+6 IF $PIECE(^ACDPD(ACDV,0),U,25)
QUIT
+7 SET ^ACDVTMP(ACDUSER,ACDV,"P")=ACD("P")
+8 FOR ACDAY=0:0
SET ACDAY=$ORDER(^ACDPD(ACDV,1,ACDAY))
IF 'ACDAY
QUIT
IF $DATA(^(ACDAY,0))
SET ACD("P")=^(0)
SET ^ACDVTMP(ACDUSER,ACDV,"P","DAY",ACDAY)=ACD("P")
+9 SET DIE="^ACDPD("
SET DA=ACDV
SET DR="25///T"
DO DIE^ACDFMC
+10 WRITE "."
+11 QUIT
V ;V node
+1 DO V^ACDVSAV2
+2 QUIT
CLN ;Make pass to clean incomplete entries
+1 DO CLN^ACDVSAV2
+2 QUIT
K ;
+1 ;Unlock options
+2 DO EN1^ACDGLOCK
+3 KILL ACDDTF,ACDDTT
+4 KILL ACDV,ACDUSER,ACDBWP,ACDDA,ACDFR,ACDTO,ACD,ACDDRUG,ACD6PGM,ACDRUG,ACDTIME,ACDPOINT
+5 ; 3-31-95 EDE
KILL ACDSCND
+6 QUIT
