- 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
