ADEXSU1.m

ADEXSU1 ; IHS/HQT/MJL  - DENTAL EXTRACT PART 3 ;  [ 05/12/1999  5:04 PM ]

 ;;6.0;ADE;**1**;MAY 12, 1999

START ;EP

 S ADERC=0

 U IO

 W !!!,?10,"D E N T A L  D A T A  E X T R A C T I O N   B E G U N",!

 ;K ^ADENDATA ;^ADENDATA is a transient working global

 D:$D(^ADENDATA)

 .S ADESUB=""

 .F  S ADESUB=$O(^ADENDATA(ADESUB)) Q:ADESUB=""  K ^ADENDATA(ADESUB)

 .K ADESUB

 I $D(ADERERUN) D

 . Q:'$D(ADEXDA)

 . S ADELETE="@"

 . S DIK="^ADELOG(",DA=ADEXDA

 . D ^DIK

 . K ADELETE,DR,DIE,DIDEL

 I '$D(ADEREX) D

 . N DIC,X,DR,ADELAST

 . S DIC="^ADELOG(",DIC(0)="L",X=ADEXDT

 . S DIC("DR")="1///"_ADEBDT_";2///"_ADEND_";3///0;4///D;5///ABORTED"

 . S ADELAST=1

 . K DD,DO

 . D FILE^DICN

 . S ADEXDA=+Y

 . K DIC,X,DR,ADELAST

 D CHKY1

 ;

 I ADERC S ^ADENDATA(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+ADEXDT)_U_(17000000+ADEBDT)_U_(17000000+ADEND)_"^^"_ADERC

 ;

 ;If it's NOT a re-extract, update both RECORD COUNT and STATUS

 ;If it IS a re-extract, update record count ONLY

 D

 . N DIE,DR,DA,ADELAST

 . S DIE="^ADELOG(",DA=ADEXDA,ADELAST=1

 . S DR="3///"_ADERC_";5///COMPLETED NORMALLY"

 . I $D(ADEREX) S DR="3///"_ADERC

 . D ^DIE

 . K DIE,DR,DA,ADELAST

 G FIN^ADEXSU3

 ;

CHKY1 ;GET FIRST DATE FROM "AF" XREF

 W !,?15,"RECORD SCANNING "

 S ADEDT=ADEBDT-1

 F  S ADEDT=$O(^ADEPCD("AC",ADEDT)) Q:(ADEDT="")!(ADEDT>ADEND)  W "." D CHKY2

 W !,?15,"COMPLETED",!

 Q

CHKY2 S ADEA=0

 I $D(^%ZOSF("TRAP")) S X="ERR^ADEXSU3",@^%ZOSF("TRAP")

RESTART ;EP

 F  S ADEA=$O(^ADEPCD("AC",ADEDT,ADEA)) Q:'+ADEA  D CHKY3

 Q

CHKY3 Q:'$D(^ADEPCD(ADEA,0))

 S ADERROR=0,ADEVNODE=^ADEPCD(ADEA,0)

 G:'$D(ADEREX) CHKY3B

 Q:$P(^ADEPCD(ADEA,0),U,6)'=ADEXDT

 D EXT1 Q:ADERROR  D VIS1 Q

CHKY3B Q:$P(^ADEPCD(ADEA,0),U,6)

 I 'ADECHS,$P(^ADEPCD(ADEA,0),U,9)="c" Q

 D EXT1 Q:ADERROR  D VIS1 Q:ADERROR

 S $P(^ADEPCD(ADEA,0),U,6)=ADEXDT,^ADEPCD("AI",ADEXDT,ADEA)=""

 Q

EXT1 ;

 S (ADEDOB,ADESEX,ADEZIP,ADENAT,ADEVDTE,ADEVDTP,ADETCOST,ADEASF,ADEHRN,ADESITE)=""

 S ADEDFN=$P(ADEVNODE,U)

 G:'$D(^DPT(ADEDFN,0)) ERR4^ADEXSU2

 S ADENODE=^DPT(ADEDFN,0)

 ;S ADEDOB=$E($P(ADENODE,U,3),2,7)

 S ADEDOB=$P(ADENODE,U,3)

 S ADESEX=$P(ADENODE,U,2)

 S:$D(^DPT(ADEDFN,.11)) ADEZIP=$P(^DPT(ADEDFN,.11),U,6)

 I '$D(^AUPNPAT(ADEDFN,11)) S ADENAT="I" Q

 S ADENAT=$P(^AUPNPAT(ADEDFN,11),U,11)

 I ADENAT="" S ADENAT="I" Q

 S ADENAT=$P(^AUTTBEN(ADENAT,0),U,2)

 S ADENAT=$S(ADENAT="01":"I",1:"O")

 Q

 ;

VIS1 ;S ADEVDTE=$E($P(ADEVNODE,U,2),2,7) ;MJL 4/26/99

 ;S ADEVDTE=$P(ADEVNODE,U,2) ;MJL 4/26/99 Need the entire internal FileMan formatted visit date to convert to the CCYYMMDD format

 S ADEVDTE=$P(ADEVNODE,U,2)\1 ;MJL 5/12/99 Performed integer divide by 1 to remove fractional part (time portion)

 I ADEVDTE="" G ERR5^ADEXSU2

 S ADEREPD=$P(ADEVNODE,U,4)

 I ADEREPD="" G ERR6^ADEXSU2

 S ADEVDTP=$S($D(^DIC(16,ADEREPD,0)):$P(^DIC(16,ADEREPD,0),U,9),1:"")

 I ADEVDTP="" G ERR12^ADEXSU2

 S ADETYPE=$S($P(ADEVNODE,U,9)="c":"K",1:"D")

 S ADESITE=$P(ADEVNODE,U,3)

 I ADESITE="" G ERR3^ADEXSU2

 I '$D(^AUTTLOC(ADESITE,0)) G ERR3^ADEXSU2

 S ADEASF=$P(^AUTTLOC(ADESITE,0),U,10) ;G:ADEASF'?6.6N ERR2^ADEXSU2

 S ADEHRN=$S($D(^AUPNPAT(ADEDFN,41,ADESITE,0)):$E(1000000+$P(^(0),U,2),2,7),1:"000000")

 S ADETCOST=$P(ADEVNODE,U,8)

 S:ADETCOST]"" ADETCOST=$E(1000000+(ADETCOST*100\1),2,7)

 S ADEASITE=$E(ADEASF,1,2),ADESUFAC=$E(ADEASF,3,6)

 I '$D(^ADEPCD(ADEA,"ADA","B")) G ERR10^ADEXSU2

 S ADESVCS=""

 S ADEADACP=0

 F ADEIDX=1:1:15 S ADEADACP=$O(^ADEPCD(ADEA,"ADA","B",ADEADACP)) Q:ADEADACP=""  D ADAQ

 S ADERC=ADERC+1,^ADENDATA(ADERC)="AD1"_U_ADENAT_U_ADETYPE_U_ADEASITE_U_ADEVDTP_U_ADESUFAC_U_(17000000+ADEVDTE)_U_U_(17000000+ADEDOB)_U_ADESEX_U_ADEASF_ADEHRN_U_ADEZIP_U_U_ADETCOST_U_ADESVCS

 Q

ADAQ Q:'$D(^AUTTADA(ADEADACP,0))

 S ADEC=0,ADEADAQ=0,ADEADAF=0

 ;

ADAQ1 S ADEC=$O(^ADEPCD(ADEA,"ADA","B",ADEADACP,ADEC))

 G:ADEC="" ADAQ2

 I '$D(^ADEPCD(ADEA,"ADA",ADEC,0)) G ADAQ1

 I $P(^ADEPCD(ADEA,"ADA",ADEC,0),U,5)]"" G ADAQ1

 S ADEADAQ=ADEADAQ+1

 S ADEADAF=ADEADAF+$P(^ADEPCD(ADEA,"ADA",ADEC,0),U,3)

 G ADAQ1

 ;

ADAQ2 S ADECOD=$P(^AUTTADA(ADEADACP,0),U)

 Q:"0191;0192;0193;0194;0195;0196;0197;0198;0199"[ADECOD

 S ADEADAQ=$E(100+ADEADAQ,2,3)

 S ADEADAF=$E(100000+$J(ADEADAF,0,0),2,6)

 S ADESVCS=ADESVCS_(ADECOD_ADEADAQ_ADEADAF)

 Q

ADEXSU1   ; IHS/HQT/MJL  - DENTAL EXTRACT PART 3 ;  [ 05/12/1999  5:04 PM ]

 +1       ;;6.0;ADE;**1**;MAY 12, 1999

START     ;EP

 +1        SET ADERC=0

 +2        USE IO

 +3        WRITE !!!,?10,"D E N T A L  D A T A  E X T R A C T I O N   B E G U N",!

 +4       ;K ^ADENDATA ;^ADENDATA is a transient working global

 +5        IF $DATA(^ADENDATA)

               Begin DoDot:1

 +6                SET ADESUB=""

 +7                FOR 

                       SET ADESUB=$ORDER(^ADENDATA(ADESUB))

                       IF ADESUB=""

                           QUIT 

                       KILL ^ADENDATA(ADESUB)

 +8                KILL ADESUB

               End DoDot:1

 +9        IF $DATA(ADERERUN)

               Begin DoDot:1

 +10               IF '$DATA(ADEXDA)

                       QUIT 

 +11               SET ADELETE="@"

 +12               SET DIK="^ADELOG("

                   SET DA=ADEXDA

 +13               DO ^DIK

 +14               KILL ADELETE,DR,DIE,DIDEL

               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///"_ADEBDT_";2///"_ADEND_";3///0;4///D;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

 +24       DO CHKY1

 +25      ;

 +26       IF ADERC

               SET ^ADENDATA(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+ADEXDT)_U_(17000000+ADEBDT)_U_(17000000+ADEND)_"^^"_ADERC

 +27      ;

 +28      ;If it's NOT a re-extract, update both RECORD COUNT and STATUS

 +29      ;If it IS a re-extract, update record count ONLY

 +30       Begin DoDot:1

 +31           NEW DIE,DR,DA,ADELAST

 +32           SET DIE="^ADELOG("

               SET DA=ADEXDA

               SET ADELAST=1

 +33           SET DR="3///"_ADERC_";5///COMPLETED NORMALLY"

 +34           IF $DATA(ADEREX)

                   SET DR="3///"_ADERC

 +35           DO ^DIE

 +36           KILL DIE,DR,DA,ADELAST

           End DoDot:1

 +37       GOTO FIN^ADEXSU3

 +38      ;

CHKY1     ;GET FIRST DATE FROM "AF" XREF

 +1        WRITE !,?15,"RECORD SCANNING "

 +2        SET ADEDT=ADEBDT-1

 +3        FOR 

               SET ADEDT=$ORDER(^ADEPCD("AC",ADEDT))

               IF (ADEDT="")!(ADEDT>ADEND)

                   QUIT 

               WRITE "."

               DO CHKY2

 +4        WRITE !,?15,"COMPLETED",!

 +5        QUIT 

CHKY2      SET ADEA=0

 +1        IF $DATA(^%ZOSF("TRAP"))

               SET X="ERR^ADEXSU3"

               SET @^%ZOSF("TRAP")

RESTART   ;EP

 +1        FOR 

               SET ADEA=$ORDER(^ADEPCD("AC",ADEDT,ADEA))

               IF '+ADEA

                   QUIT 

               DO CHKY3

 +2        QUIT 

CHKY3      IF '$DATA(^ADEPCD(ADEA,0))

               QUIT 

 +1        SET ADERROR=0

           SET ADEVNODE=^ADEPCD(ADEA,0)

 +2        IF '$DATA(ADEREX)

               GOTO CHKY3B

 +3        IF $PIECE(^ADEPCD(ADEA,0),U,6)'=ADEXDT

               QUIT 

 +4        DO EXT1

           IF ADERROR

               QUIT 

           DO VIS1

           QUIT 

CHKY3B     IF $PIECE(^ADEPCD(ADEA,0),U,6)

               QUIT 

 +1        IF 'ADECHS

               IF $PIECE(^ADEPCD(ADEA,0),U,9)="c"

                   QUIT 

 +2        DO EXT1

           IF ADERROR

               QUIT 

           DO VIS1

           IF ADERROR

               QUIT 

 +3        SET $PIECE(^ADEPCD(ADEA,0),U,6)=ADEXDT

           SET ^ADEPCD("AI",ADEXDT,ADEA)=""

 +4        QUIT 

EXT1      ;

 +1        SET (ADEDOB,ADESEX,ADEZIP,ADENAT,ADEVDTE,ADEVDTP,ADETCOST,ADEASF,ADEHRN,ADESITE)=""

 +2        SET ADEDFN=$PIECE(ADEVNODE,U)

 +3        IF '$DATA(^DPT(ADEDFN,0))

               GOTO ERR4^ADEXSU2

 +4        SET ADENODE=^DPT(ADEDFN,0)

 +5       ;S ADEDOB=$E($P(ADENODE,U,3),2,7)

 +6        SET ADEDOB=$PIECE(ADENODE,U,3)

 +7        SET ADESEX=$PIECE(ADENODE,U,2)

 +8        IF $DATA(^DPT(ADEDFN,.11))

               SET ADEZIP=$PIECE(^DPT(ADEDFN,.11),U,6)

 +9        IF '$DATA(^AUPNPAT(ADEDFN,11))

               SET ADENAT="I"

               QUIT 

 +10       SET ADENAT=$PIECE(^AUPNPAT(ADEDFN,11),U,11)

 +11       IF ADENAT=""

               SET ADENAT="I"

               QUIT 

 +12       SET ADENAT=$PIECE(^AUTTBEN(ADENAT,0),U,2)

 +13       SET ADENAT=$SELECT(ADENAT="01":"I",1:"O")

 +14       QUIT 

 +15      ;

VIS1      ;S ADEVDTE=$E($P(ADEVNODE,U,2),2,7) ;MJL 4/26/99

 +1       ;S ADEVDTE=$P(ADEVNODE,U,2) ;MJL 4/26/99 Need the entire internal FileMan formatted visit date to convert to the CCYYMMDD format

 +2       ;MJL 5/12/99 Performed integer divide by 1 to remove fractional part (time portion)

           SET ADEVDTE=$PIECE(ADEVNODE,U,2)\1

 +3        IF ADEVDTE=""

               GOTO ERR5^ADEXSU2

 +4        SET ADEREPD=$PIECE(ADEVNODE,U,4)

 +5        IF ADEREPD=""

               GOTO ERR6^ADEXSU2

 +6        SET ADEVDTP=$SELECT($DATA(^DIC(16,ADEREPD,0)):$PIECE(^DIC(16,ADEREPD,0),U,9),1:"")

 +7        IF ADEVDTP=""

               GOTO ERR12^ADEXSU2

 +8        SET ADETYPE=$SELECT($PIECE(ADEVNODE,U,9)="c":"K",1:"D")

 +9        SET ADESITE=$PIECE(ADEVNODE,U,3)

 +10       IF ADESITE=""

               GOTO ERR3^ADEXSU2

 +11       IF '$DATA(^AUTTLOC(ADESITE,0))

               GOTO ERR3^ADEXSU2

 +12      ;G:ADEASF'?6.6N ERR2^ADEXSU2

           SET ADEASF=$PIECE(^AUTTLOC(ADESITE,0),U,10)

 +13       SET ADEHRN=$SELECT($DATA(^AUPNPAT(ADEDFN,41,ADESITE,0)):$EXTRACT(1000000+$PIECE(^(0),U,2),2,7),1:"000000")

 +14       SET ADETCOST=$PIECE(ADEVNODE,U,8)

 +15       IF ADETCOST]""

               SET ADETCOST=$EXTRACT(1000000+(ADETCOST*100\1),2,7)

 +16       SET ADEASITE=$EXTRACT(ADEASF,1,2)

           SET ADESUFAC=$EXTRACT(ADEASF,3,6)

 +17       IF '$DATA(^ADEPCD(ADEA,"ADA","B"))

               GOTO ERR10^ADEXSU2

 +18       SET ADESVCS=""

 +19       SET ADEADACP=0

 +20       FOR ADEIDX=1:1:15

               SET ADEADACP=$ORDER(^ADEPCD(ADEA,"ADA","B",ADEADACP))

               IF ADEADACP=""

                   QUIT 

               DO ADAQ

 +21       SET ADERC=ADERC+1

           SET ^ADENDATA(ADERC)="AD1"_U_ADENAT_U_ADETYPE_U_ADEASITE_U_ADEVDTP_U_ADESUFAC_U_(17000000+ADEVDTE)_U_U_(17000000+ADEDOB)_U_ADESEX_U_ADEASF_ADEHRN_U_ADEZIP_U_U_ADETCOST_U_ADESVCS

 +22       QUIT 

ADAQ       IF '$DATA(^AUTTADA(ADEADACP,0))

               QUIT 

 +1        SET ADEC=0

           SET ADEADAQ=0

           SET ADEADAF=0

 +2       ;

ADAQ1      SET ADEC=$ORDER(^ADEPCD(ADEA,"ADA","B",ADEADACP,ADEC))

 +1        IF ADEC=""

               GOTO ADAQ2

 +2        IF '$DATA(^ADEPCD(ADEA,"ADA",ADEC,0))

               GOTO ADAQ1

 +3        IF $PIECE(^ADEPCD(ADEA,"ADA",ADEC,0),U,5)]""

               GOTO ADAQ1

 +4        SET ADEADAQ=ADEADAQ+1

 +5        SET ADEADAF=ADEADAF+$PIECE(^ADEPCD(ADEA,"ADA",ADEC,0),U,3)

 +6        GOTO ADAQ1

 +7       ;

ADAQ2      SET ADECOD=$PIECE(^AUTTADA(ADEADACP,0),U)

 +1        IF "0191;0192;0193;0194;0195;0196;0197;0198;0199"[ADECOD

               QUIT 

 +2        SET ADEADAQ=$EXTRACT(100+ADEADAQ,2,3)

 +3        SET ADEADAF=$EXTRACT(100000+$JUSTIFY(ADEADAF,0,0),2,6)

 +4        SET ADESVCS=ADESVCS_(ADECOD_ADEADAQ_ADEADAF)

 +5        QUIT