ADEFLEX0 ; IHS/HQT/MJL - EXTRACT F- DATA PART 2 ; [ 03/29/1999 8:33 AM ]
;;6.0;ADE;;APRIL 1999
; ^ADEFDATA is a transient, non-fileman working global
W !!,"Fluoride Data Extraction for Transmission to Area/DPSB",!!
D ^XBKVAR
G:'$D(^ADEFDATA) OK
W "The data extraction holding area will be purged if you continue.",!
CONFIRM R "Ok to continue? N// ",X:DTIME S:'$T X=U S X=$E(X_"N")
I X["?" W !,"It is ok to clear the data extraction holding file if a cartridge",!,"containing that extracted data has been made and sent to AREA or DPSB.",! G CONFIRM
I "Yy"'[X W " -- data extraction canceled.",! G QUIT
OK G:$D(ADEREX) ASKDEV
DATE S U="^",%DT="AXEP",%DT("A")="SELECT BEGINNING DATE: " D ^%DT
G:Y<0 QUIT S ADEB=Y,%DT(0)=ADEB,%DT("A")="SELECT ENDING DATE: " D ^%DT
G:X="^" DATE G:Y<0 QUIT S ADEND=Y
ASKDEV S %ZIS="Q" D ^%ZIS G QUIT:POP I $D(IO("Q")) K IO("Q") D QUE W !,"REQUEST QUEUED." G QUIT
U IO G START
QUE S ZTRTN="START^ADEFLEX0",ZTDESC="DENTAL FLUORIDATION DATA",ZTSAVE("ADEND")="",ZTSAVE("ADEB")="",ZTSAVE("ADEXDT")="" S:$D(ADEREX) ZTSAVE("ADEREX")="",ZTSAVE("ADEXDA")=""
S:$D(ADERERUN) ZTSAVE("ADERERUN")="",ZTSAVE("ADEXDA")="" D ^%ZTLOAD Q
END S ^ADEFDATA(0)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)_U_$P(^DIC(4,$P(^AUTTSITE(1,0),U,1),0),U,1)_U_(17000000+DT)_U_(17000000+ADEB)_U_(17000000+ADEND)_"^^"_(ADERC-1)
D
. N DIE,DR,DA,ADELAST
. S DIE="^ADELOG(",DA=ADEXDA,ADELAST=1
. S DR="3///"_(ADERC-1)_";5///COMPLETED NORMALLY"
. I $D(ADEREX) S DR="3///"_(ADERC-1)
. D ^DIE
. K DIE,DR,DA,ADELAST
W !!,?15,"PROCESSING COMPLETE. ",ADERC-1," RECORDS PROCESSED."
D ^%ZISC
QUIT K ADEB,ADEBD,ADED0,ADED1,ADEDUZ,ADEEQ,ADEFDV,ADEID,ADELAST,ADELDAY,ADEND,ADENM,ADENO,ADEPPM,ADERC,ADERERUN,ADERES,ADESFC,ADESTAT,ADEWP,ADEXDA,ADEXDT,ADEXNOD,ADERR,ADESSN,ADEREX
Q
START ;
U IO ;D HOME^%ZIS
W !!!,?15,"FLUORIDATION DATA EXTRACTION BEGUN...",!!,?15,"RECORD SCANNING "
;S ADEBD=ADEB-1,ADERC=1 K ^ADEFDATA ;NON-FILEMAN EXTRACT GLOBAL
S ADEBD=ADEB-1,ADERC=1
D:$D(^ADEFDATA)
.S ADESUB="" F S ADESUB=$O(^ADEFDATA(ADESUB)) Q:ADESUB="" K ^ADEFDATA(ADESUB)
.K ADESUB
I $D(ADERERUN) D
. Q:'$D(ADEXDA)
. Q:'+ADEXDA
. Q:'$D(^ADELOG(ADEXDA,0))
. S DIK="^ADELOG(",DA=ADEXDA
. D ^DIK
. K DIK,DA
I '$D(ADEREX) D
. N DIC,X,DR,ADELAST
. S DIC="^ADELOG(",DIC(0)="L",X=ADEXDT
. S DIC("DR")="1///"_ADEB_";2///"_ADEND_";3///0;4///F;5///ABORTED"
. S ADELAST=1
. K DD,DO
. D FILE^DICN
. S ADEXDA=+Y
. K DIC,X,DR,ADELAST
S1 S ADED0=0,ADEBD=$O(^ADEFLU("AB",ADEBD)) G:(ADEBD>ADEND)!(ADEBD="") END
S2 ;EP
S ADED1=0,ADENM="",ADESFC="",ADED0=$O(^ADEFLU("AB",ADEBD,ADED0)) G:(ADED0="") S1
G:'$D(^ADEFLU(ADED0,0)) ERR1^ADEFLEX1 S ADEWP=$P(^ADEFLU(ADED0,0),U)
G:'$D(^ADEWS(ADEWP,0)) ERR2^ADEFLEX1 S ADEWP=^ADEWS(ADEWP,0),ADENM=$P(ADEWP,U),ADESFC=$P(ADEWP,U,2) G:(ADENM="")!(ADESFC="") ERR3^ADEFLEX1
S3 ;EP
S ADED1=$O(^ADEFLU("AB",ADEBD,ADED0,ADED1)) G:ADED1="" S2
G:'$D(^ADEFLU(ADED0,1,ADED1,0)) ERR4^ADEFLEX1
S ADENO=^ADEFLU(ADED0,1,ADED1,0)
I '$D(ADEREX),$P(ADENO,U,5)]"" G S3
I $D(ADEREX),$P(ADENO,U,5)'=ADEXDT G S3
S ADEEQ=$P(ADENO,U,3) S:ADEEQ="O" ADEEQ="X" G:ADEEQ="" ERR5^ADEFLEX1
S ADEID=$P(ADENO,U,4) G:ADEID="" ERR6^ADEFLEX1
G:'$D(^DIC(16,ADEID,0)) ERR7^ADEFLEX1
S ADESSN=$P(^DIC(16,ADEID,0),U,9) G:ADESSN'?9N ERR8^ADEFLEX1 S ADEID=ADESSN
S ADEPPM=$P(ADENO,U,2) G:ADEPPM="" ERR9^ADEFLEX1 S ADEPPM=ADEPPM*10,ADEPPM="000"_ADEPPM,ADEPPM=$E(ADEPPM,$L(ADEPPM)-2,$L(ADEPPM))
;S ^ADEFDATA(ADERC)="AD2^21^"_$E(ADEBD,4,5)_$E(ADEBD,6,7)_$E(ADEBD,2,3)_U_ADEEQ_ADESFC_ADEPPM_U_ADEID,ADERC=ADERC+1
S ^ADEFDATA(ADERC)="AD2^21^"_(17000000+ADEBD)_U_ADEEQ_ADESFC_ADEPPM_U_ADEID,ADERC=ADERC+1
I '$D(ADEREX) S DIE=9002002.1,DA=ADED0,DR="1///`"_ADED1,DR(2,9002002.11)="4////"_DT D ^DIE
W "." G S3
ADEFLEX0 ; IHS/HQT/MJL - EXTRACT F- DATA PART 2 ; [ 03/29/1999 8:33 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ; ^ADEFDATA is a transient, non-fileman working global
+3 WRITE !!,"Fluoride Data Extraction for Transmission to Area/DPSB",!!
+4 DO ^XBKVAR
+5 IF '$DATA(^ADEFDATA)
GOTO OK
+6 WRITE "The data extraction holding area will be purged if you continue.",!
CONFIRM READ "Ok to continue? N// ",X:DTIME
IF '$TEST
SET X=U
SET X=$EXTRACT(X_"N")
+1 IF X["?"
WRITE !,"It is ok to clear the data extraction holding file if a cartridge",!,"containing that extracted data has been made and sent to AREA or DPSB.",!
GOTO CONFIRM
+2 IF "Yy"'[X
WRITE " -- data extraction canceled.",!
GOTO QUIT
OK IF $DATA(ADEREX)
GOTO ASKDEV
DATE SET U="^"
SET %DT="AXEP"
SET %DT("A")="SELECT BEGINNING DATE: "
DO ^%DT
+1 IF Y<0
GOTO QUIT
SET ADEB=Y
SET %DT(0)=ADEB
SET %DT("A")="SELECT ENDING DATE: "
DO ^%DT
+2 IF X="^"
GOTO DATE
IF Y<0
GOTO QUIT
SET ADEND=Y
ASKDEV SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO QUIT
IF $DATA(IO("Q"))
KILL IO("Q")
DO QUE
WRITE !,"REQUEST QUEUED."
GOTO QUIT
+1 USE IO
GOTO START
QUE SET ZTRTN="START^ADEFLEX0"
SET ZTDESC="DENTAL FLUORIDATION DATA"
SET ZTSAVE("ADEND")=""
SET ZTSAVE("ADEB")=""
SET ZTSAVE("ADEXDT")=""
IF $DATA(ADEREX)
SET ZTSAVE("ADEREX")=""
SET ZTSAVE("ADEXDA")=""
+1 IF $DATA(ADERERUN)
SET ZTSAVE("ADERERUN")=""
SET ZTSAVE("ADEXDA")=""
DO ^%ZTLOAD
QUIT
END SET ^ADEFDATA(0)=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0),U,10)_U_$PIECE(^DIC(4,$PIECE(^AUTTSITE(1,0),U,1),0),U,1)_U_(17000000+DT)_U_(17000000+ADEB)_U_(17000000+ADEND)_"^^"_(ADERC-1)
+1 Begin DoDot:1
+2 NEW DIE,DR,DA,ADELAST
+3 SET DIE="^ADELOG("
SET DA=ADEXDA
SET ADELAST=1
+4 SET DR="3///"_(ADERC-1)_";5///COMPLETED NORMALLY"
+5 IF $DATA(ADEREX)
SET DR="3///"_(ADERC-1)
+6 DO ^DIE
+7 KILL DIE,DR,DA,ADELAST
End DoDot:1
+8 WRITE !!,?15,"PROCESSING COMPLETE. ",ADERC-1," RECORDS PROCESSED."
+9 DO ^%ZISC
QUIT KILL ADEB,ADEBD,ADED0,ADED1,ADEDUZ,ADEEQ,ADEFDV,ADEID,ADELAST,ADELDAY,ADEND,ADENM,ADENO,ADEPPM,ADERC,ADERERUN,ADERES,ADESFC,ADESTAT,ADEWP,ADEXDA,ADEXDT,ADEXNOD,ADERR,ADESSN,ADEREX
+1 QUIT
START ;
+1 ;D HOME^%ZIS
USE IO
+2 WRITE !!!,?15,"FLUORIDATION DATA EXTRACTION BEGUN...",!!,?15,"RECORD SCANNING "
+3 ;S ADEBD=ADEB-1,ADERC=1 K ^ADEFDATA ;NON-FILEMAN EXTRACT GLOBAL
+4 SET ADEBD=ADEB-1
SET ADERC=1
+5 IF $DATA(^ADEFDATA)
Begin DoDot:1
+6 SET ADESUB=""
FOR
SET ADESUB=$ORDER(^ADEFDATA(ADESUB))
IF ADESUB=""
QUIT
KILL ^ADEFDATA(ADESUB)
+7 KILL ADESUB
End DoDot:1
+8 IF $DATA(ADERERUN)
Begin DoDot:1
+9 IF '$DATA(ADEXDA)
QUIT
+10 IF '+ADEXDA
QUIT
+11 IF '$DATA(^ADELOG(ADEXDA,0))
QUIT
+12 SET DIK="^ADELOG("
SET DA=ADEXDA
+13 DO ^DIK
+14 KILL DIK,DA
End DoDot:1
+15 IF '$DATA(ADEREX)
Begin DoDot:1
+16 NEW DIC,X,DR,ADELAST
+17 SET DIC="^ADELOG("
SET DIC(0)="L"
SET X=ADEXDT
+18 SET DIC("DR")="1///"_ADEB_";2///"_ADEND_";3///0;4///F;5///ABORTED"
+19 SET ADELAST=1
+20 KILL DD,DO
+21 DO FILE^DICN
+22 SET ADEXDA=+Y
+23 KILL DIC,X,DR,ADELAST
End DoDot:1
S1 SET ADED0=0
SET ADEBD=$ORDER(^ADEFLU("AB",ADEBD))
IF (ADEBD>ADEND)!(ADEBD="")
GOTO END
S2 ;EP
+1 SET ADED1=0
SET ADENM=""
SET ADESFC=""
SET ADED0=$ORDER(^ADEFLU("AB",ADEBD,ADED0))
IF (ADED0="")
GOTO S1
+2 IF '$DATA(^ADEFLU(ADED0,0))
GOTO ERR1^ADEFLEX1
SET ADEWP=$PIECE(^ADEFLU(ADED0,0),U)
+3 IF '$DATA(^ADEWS(ADEWP,0))
GOTO ERR2^ADEFLEX1
SET ADEWP=^ADEWS(ADEWP,0)
SET ADENM=$PIECE(ADEWP,U)
SET ADESFC=$PIECE(ADEWP,U,2)
IF (ADENM="")!(ADESFC="")
GOTO ERR3^ADEFLEX1
S3 ;EP
+1 SET ADED1=$ORDER(^ADEFLU("AB",ADEBD,ADED0,ADED1))
IF ADED1=""
GOTO S2
+2 IF '$DATA(^ADEFLU(ADED0,1,ADED1,0))
GOTO ERR4^ADEFLEX1
+3 SET ADENO=^ADEFLU(ADED0,1,ADED1,0)
+4 IF '$DATA(ADEREX)
IF $PIECE(ADENO,U,5)]""
GOTO S3
+5 IF $DATA(ADEREX)
IF $PIECE(ADENO,U,5)'=ADEXDT
GOTO S3
+6 SET ADEEQ=$PIECE(ADENO,U,3)
IF ADEEQ="O"
SET ADEEQ="X"
IF ADEEQ=""
GOTO ERR5^ADEFLEX1
+7 SET ADEID=$PIECE(ADENO,U,4)
IF ADEID=""
GOTO ERR6^ADEFLEX1
+8 IF '$DATA(^DIC(16,ADEID,0))
GOTO ERR7^ADEFLEX1
+9 SET ADESSN=$PIECE(^DIC(16,ADEID,0),U,9)
IF ADESSN'?9N
GOTO ERR8^ADEFLEX1
SET ADEID=ADESSN
+10 SET ADEPPM=$PIECE(ADENO,U,2)
IF ADEPPM=""
GOTO ERR9^ADEFLEX1
SET ADEPPM=ADEPPM*10
SET ADEPPM="000"_ADEPPM
SET ADEPPM=$EXTRACT(ADEPPM,$LENGTH(ADEPPM)-2,$LENGTH(ADEPPM))
+11 ;S ^ADEFDATA(ADERC)="AD2^21^"_$E(ADEBD,4,5)_$E(ADEBD,6,7)_$E(ADEBD,2,3)_U_ADEEQ_ADESFC_ADEPPM_U_ADEID,ADERC=ADERC+1
+12 SET ^ADEFDATA(ADERC)="AD2^21^"_(17000000+ADEBD)_U_ADEEQ_ADESFC_ADEPPM_U_ADEID
SET ADERC=ADERC+1
+13 IF '$DATA(ADEREX)
SET DIE=9002002.1
SET DA=ADED0
SET DR="1///`"_ADED1
SET DR(2,9002002.11)="4////"_DT
DO ^DIE
+14 WRITE "."
GOTO S3
