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
