ADEGRL6 ; IHS/HQT/MJL - FILE DENTAL VISIT DATA ;10:12 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**12,26**;APRIL 1999;Build 13
;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
K DIC
;S J="" F S J=$O(ADEV(J)) Q:'J W !,"ADEV(",J,")=",ADEV(J)
;R X ;IHS/HMW 5-12-90 REMOVE AFTER TESTING
I ADENOUPD G END
I ADENEWVS,'$D(ADEV) G END
;------->QUEUE WRITES IF BACKGROUND ENABLED, TASKMAN RUNNING
G ZTM ;IHS/SET/HMW 2-6-2003 **12** Background writes disabled
G:$P(^ADEPARAM(+^AUTTSITE(1,0),0),U,4)'="y" ZTM
I $S($D(^%ZTSCH("RUN"))[0:1,^("RUN")-$H:1,1:$P($H,",",2)-150>$P(^("RUN"),",",2)) W *7,!,"TASK MANAGER NOT RUNNING -- BACKGROUND WRITES DISABLED",!,"PLEASE WAIT WHILE I UPDATE THE DENTAL FILE",! G ZTM
D ^ADEQUE
; ^ADEUTL is a transient, non-fileman working global
I '$D(^ADEUTL("ADEDQUE")) S ^ADEUTL("ADEDQUE")=1,ZTRTN="^ADEDQUE",ZTDTH=$H,ZTDESC="DENTAL DISC WRITES",ZTIO="" D ^%ZTLOAD
G END1
ZTM ;------->IF NEW VISIT CREATE ENTRY IN ADEPCD (ENTRY POINT FOR ^ADEDQUE)
I ADENEWVS D NEWVS
;------->IF MODIFICATION OF EXISTING VISIT DELETE OLD SVCS DATA
I 'ADENEWVS D SDEL
;------->NEW LOCATION AND PROVIDER DATA INTO ADEPCD
K DIE,DA,DR D STUFA
;------->NEW SERVICE DATA INTO ADEPCD
K DIE,DA,DR D STUFB
;------->FAILED APPT & FOLLOWUP PROCESSING
;/IHS/OIT/GAB 11.2014 Patch #26 modified below line to add 2015 codes 9986 & 9987 (do not remove old codes yet)
;I ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))) D FAIL,FOL G END
I ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))!$D(ADEV("9986"))!$D(ADEV("9987"))) D FAIL,FOL G END
;------->UPDATE PCC FILES
D ^ADEAPC
END K ^ADEUTL("ADELOCK",ADEPAT)
END1 K ADEFLG,ADENOTE,ADEVDATE,ADENOUPD,ADENEWVS,ADEPAT,ADERDNM,ADERDNMD,ADELOE,ADELOED,ADEPVNM,ADEPVNMD,ADEV,ADEDES,ADEPNM,ADEHRN,ADEDENT,ADETITL,ADECOD,ADEDEL,ADEOP,ADECNT,ADEQTY,ADEDEF,ADEI,ADETCH,ADETCHF,ADETFE
K ADEHXC,ADEHXO,ADEHXF
Q
;
NEWVS S DIC="^ADEPCD(",DIC(0)="LZ",X=ADEPAT,DIC("DR")="1///"_ADEVDATE K DD,DO D FILE^DICN S ADEDFN=$P(Y,U)
Q
;
SDEL ;
S DIE="^ADEPCD(",DA=ADEDFN,DR(2,9002007.01)=".01///@",ADESVC=0
SDEL1 S ADESVC=$O(^ADEPCD(ADEDFN,"ADA",ADESVC))
I ADESVC="" K ADESVC,DR,DIE,DA Q
S DR="100///`"_ADESVC D ^DIE G SDEL1
STUFA S DA=ADEDFN,DR="2///`"_ADELOED_";"_$S(ADEPVNMD]"":"4///`"_ADEPVNMD_";",1:"")_$S(ADENOTE]"":"6///^S X=ADENOTE;",1:"")_$S(ADECON:"7///"_ADETCH_";8///c;",1:"8///d;")_"3///`"_ADERDNMD,DIE="^ADEPCD(" D ^DIE Q
STUFB S DA(1)=ADEDFN
S DIE="^ADEPCD(DA(1),""ADA"",",^ADEPCD(DA(1),"ADA",0)="^9002007.01IPA^^",ADEJ=0,DA=0
ROLL S ADEJ=$O(ADEV(ADEJ)) G:ADEJ="" RO1 S ADEI=$O(^AUTTADA("B",ADEJ,0))
RO1A S ADECNT=0 F DA=DA+1:1:DA+$P(ADEV(ADEJ),U) S ADECNT=ADECNT+1,DR=".01///`"_ADEI D RO1B S:ADECON DR=DR_";3///"_$P(ADEV(ADEJ),U,3) D ^DIE ;IHS/HMW 5-12-90
G ROLL
RO1B I $P($P(ADEV(ADEJ),U,2),",",ADECNT)]"" S DR=DR_";2///`"_$P($P(ADEV(ADEJ),U,2),",",ADECNT)
I $P($P(ADEV(ADEJ),U,4),",",ADECNT)]"" S DR=DR_";4///"_$P($P(ADEV(ADEJ),U,4),",",ADECNT)
I $P($P(ADEV(ADEJ),U,5),",",ADECNT)]"" S DR=DR_";5///y"
Q
RO1 S $P(^ADEPCD(ADEDFN,"ADA",0),U,3)=DA S $P(^(0),U,4)=DA
Q
FAIL ;
K DIC,DIE,DA,DR,X,Y
I '$D(^ADEPAT(ADEPAT)) S DIC="^ADEPAT(",DIC(0)="LZ",X=ADEPAT,DINUM=X K DD,DO D FILE^DICN
S DA(1)=ADEPAT
S DIE="^ADEPAT(DA(1),""FA"","
I $D(^ADEPAT(ADEPAT,"FA",0)) S DA=$P(^ADEPAT(ADEPAT,"FA",0),U,3)+1
E S ^ADEPAT(ADEPAT,"FA",0)="^9002010.22DA^^",DA=1
;/IHS/OIT/GAB 11.2014 Patch #26 Removed below and added the next line to include new code 9986 (do not remove old codes yet)
;S DR=".01///"_ADEVDATE_";1///"_$S($D(ADEV("9130")):"b",1:"c")
S DR=".01///"_ADEVDATE_";1///"_$S($D(ADEV("9130")):"b",$D(ADEV("9986")):"b",1:"c")
D ^DIE
S $P(^ADEPAT(ADEPAT,"FA",0),U,3)=DA,$P(^ADEPAT(ADEPAT,"FA",0),U,4)=$P(^ADEPAT(ADEPAT,"FA",0),U,4)+1
Q
FOL ;IF FAILED APPT SEND MESSG IF ON URGENT RECALL
Q:'$D(^ADEFOL("TYPE",ADEPAT,"rc"))
S ADETYP=0 F ADEQ=0:0 S ADETYP=$O(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP)) Q:'+ADETYP S ADEMDFN=0 F ADER=0:0 S ADEMDFN=$O(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP,ADEMDFN)) Q:'+ADEMDFN D MSG
K ADETYP,ADEMDFN,ADEQ,ADER,XMB Q
MSG Q:'$D(^ADEFOL(ADEMDFN,0))
K XMB
I $P(^ADEFOL(ADEMDFN,0),U,5)="u" S XMB(1)=$P(^DPT(ADEPAT,0),U),XMB(2)=ADEVDATE I $P(^ADEFOL(ADEMDFN,0),U,7)]"",$D(^DIC(16,$P(^ADEFOL(ADEMDFN,0),U,7),0)) S XMB(3)=$P(^DIC(16,$P(^ADEFOL(ADEMDFN,0),U,7),0),U)
I $D(XMB) D
. S XMB="ADECALL"
. S XMDUZ="DENTAL RECALL SYSTEM"
. D ^XMB
. K XMB
Q
ADEGRL6 ; IHS/HQT/MJL - FILE DENTAL VISIT DATA ;10:12 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**12,26**;APRIL 1999;Build 13
+2 ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
+3 KILL DIC
+4 ;S J="" F S J=$O(ADEV(J)) Q:'J W !,"ADEV(",J,")=",ADEV(J)
+5 ;R X ;IHS/HMW 5-12-90 REMOVE AFTER TESTING
+6 IF ADENOUPD
GOTO END
+7 IF ADENEWVS
IF '$DATA(ADEV)
GOTO END
+8 ;------->QUEUE WRITES IF BACKGROUND ENABLED, TASKMAN RUNNING
+9 ;IHS/SET/HMW 2-6-2003 **12** Background writes disabled
GOTO ZTM
+10 IF $PIECE(^ADEPARAM(+^AUTTSITE(1,0),0),U,4)'="y"
GOTO ZTM
+11 IF $SELECT($DATA(^%ZTSCH("RUN"))[0:1,^("RUN")-$HOROLOG:1,1:$PIECE($HOROLOG,",",2)-150>$PIECE(^("RUN"),",",2))
WRITE *7,!,"TASK MANAGER NOT RUNNING -- BACKGROUND WRITES DISABLED",!,"PLEASE WAIT WHILE I UPDATE THE DENTAL FILE",!
GOTO ZTM
+12 DO ^ADEQUE
+13 ; ^ADEUTL is a transient, non-fileman working global
+14 IF '$DATA(^ADEUTL("ADEDQUE"))
SET ^ADEUTL("ADEDQUE")=1
SET ZTRTN="^ADEDQUE"
SET ZTDTH=$HOROLOG
SET ZTDESC="DENTAL DISC WRITES"
SET ZTIO=""
DO ^%ZTLOAD
+15 GOTO END1
ZTM ;------->IF NEW VISIT CREATE ENTRY IN ADEPCD (ENTRY POINT FOR ^ADEDQUE)
+1 IF ADENEWVS
DO NEWVS
+2 ;------->IF MODIFICATION OF EXISTING VISIT DELETE OLD SVCS DATA
+3 IF 'ADENEWVS
DO SDEL
+4 ;------->NEW LOCATION AND PROVIDER DATA INTO ADEPCD
+5 KILL DIE,DA,DR
DO STUFA
+6 ;------->NEW SERVICE DATA INTO ADEPCD
+7 KILL DIE,DA,DR
DO STUFB
+8 ;------->FAILED APPT & FOLLOWUP PROCESSING
+9 ;/IHS/OIT/GAB 11.2014 Patch #26 modified below line to add 2015 codes 9986 & 9987 (do not remove old codes yet)
+10 ;I ADENEWVS,($D(ADEV("9130"))!$D(ADEV("9140"))) D FAIL,FOL G END
+11 IF ADENEWVS
IF ($DATA(ADEV("9130"))!$DATA(ADEV("9140"))!$DATA(ADEV("9986"))!$DATA(ADEV("9987")))
DO FAIL
DO FOL
GOTO END
+12 ;------->UPDATE PCC FILES
+13 DO ^ADEAPC
END KILL ^ADEUTL("ADELOCK",ADEPAT)
END1 KILL ADEFLG,ADENOTE,ADEVDATE,ADENOUPD,ADENEWVS,ADEPAT,ADERDNM,ADERDNMD,ADELOE,ADELOED,ADEPVNM,ADEPVNMD,ADEV,ADEDES,ADEPNM,ADEHRN,ADEDENT,ADETITL,ADECOD,ADEDEL,ADEOP,ADECNT,ADEQTY,ADEDEF,ADEI,ADETCH,ADETCHF,ADETFE
+1 KILL ADEHXC,ADEHXO,ADEHXF
+2 QUIT
+3 ;
NEWVS SET DIC="^ADEPCD("
SET DIC(0)="LZ"
SET X=ADEPAT
SET DIC("DR")="1///"_ADEVDATE
KILL DD,DO
DO FILE^DICN
SET ADEDFN=$PIECE(Y,U)
+1 QUIT
+2 ;
SDEL ;
+1 SET DIE="^ADEPCD("
SET DA=ADEDFN
SET DR(2,9002007.01)=".01///@"
SET ADESVC=0
SDEL1 SET ADESVC=$ORDER(^ADEPCD(ADEDFN,"ADA",ADESVC))
+1 IF ADESVC=""
KILL ADESVC,DR,DIE,DA
QUIT
+2 SET DR="100///`"_ADESVC
DO ^DIE
GOTO SDEL1
STUFA SET DA=ADEDFN
SET DR="2///`"_ADELOED_";"_$SELECT(ADEPVNMD]"":"4///`"_ADEPVNMD_";",1:"")_$SELECT(ADENOTE]"":"6///^S X=ADENOTE;",1:"")_$SELECT(ADECON:"7///"_ADETCH_";8///c;",1:"8///d;")_"3///`"_ADERDNMD
SET DIE="^ADEPCD("
DO ^DIE
QUIT
STUFB SET DA(1)=ADEDFN
+1 SET DIE="^ADEPCD(DA(1),""ADA"","
SET ^ADEPCD(DA(1),"ADA",0)="^9002007.01IPA^^"
SET ADEJ=0
SET DA=0
ROLL SET ADEJ=$ORDER(ADEV(ADEJ))
IF ADEJ=""
GOTO RO1
SET ADEI=$ORDER(^AUTTADA("B",ADEJ,0))
RO1A ;IHS/HMW 5-12-90
SET ADECNT=0
FOR DA=DA+1:1:DA+$PIECE(ADEV(ADEJ),U)
SET ADECNT=ADECNT+1
SET DR=".01///`"_ADEI
DO RO1B
IF ADECON
SET DR=DR_";3///"_$PIECE(ADEV(ADEJ),U,3)
DO ^DIE
+1 GOTO ROLL
RO1B IF $PIECE($PIECE(ADEV(ADEJ),U,2),",",ADECNT)]""
SET DR=DR_";2///`"_$PIECE($PIECE(ADEV(ADEJ),U,2),",",ADECNT)
+1 IF $PIECE($PIECE(ADEV(ADEJ),U,4),",",ADECNT)]""
SET DR=DR_";4///"_$PIECE($PIECE(ADEV(ADEJ),U,4),",",ADECNT)
+2 IF $PIECE($PIECE(ADEV(ADEJ),U,5),",",ADECNT)]""
SET DR=DR_";5///y"
+3 QUIT
RO1 SET $PIECE(^ADEPCD(ADEDFN,"ADA",0),U,3)=DA
SET $PIECE(^(0),U,4)=DA
+1 QUIT
FAIL ;
+1 KILL DIC,DIE,DA,DR,X,Y
+2 IF '$DATA(^ADEPAT(ADEPAT))
SET DIC="^ADEPAT("
SET DIC(0)="LZ"
SET X=ADEPAT
SET DINUM=X
KILL DD,DO
DO FILE^DICN
+3 SET DA(1)=ADEPAT
+4 SET DIE="^ADEPAT(DA(1),""FA"","
+5 IF $DATA(^ADEPAT(ADEPAT,"FA",0))
SET DA=$PIECE(^ADEPAT(ADEPAT,"FA",0),U,3)+1
+6 IF '$TEST
SET ^ADEPAT(ADEPAT,"FA",0)="^9002010.22DA^^"
SET DA=1
+7 ;/IHS/OIT/GAB 11.2014 Patch #26 Removed below and added the next line to include new code 9986 (do not remove old codes yet)
+8 ;S DR=".01///"_ADEVDATE_";1///"_$S($D(ADEV("9130")):"b",1:"c")
+9 SET DR=".01///"_ADEVDATE_";1///"_$SELECT($DATA(ADEV("9130")):"b",$DATA(ADEV("9986")):"b",1:"c")
+10 DO ^DIE
+11 SET $PIECE(^ADEPAT(ADEPAT,"FA",0),U,3)=DA
SET $PIECE(^ADEPAT(ADEPAT,"FA",0),U,4)=$PIECE(^ADEPAT(ADEPAT,"FA",0),U,4)+1
+12 QUIT
FOL ;IF FAILED APPT SEND MESSG IF ON URGENT RECALL
+1 IF '$DATA(^ADEFOL("TYPE",ADEPAT,"rc"))
QUIT
+2 SET ADETYP=0
FOR ADEQ=0:0
SET ADETYP=$ORDER(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP))
IF '+ADETYP
QUIT
SET ADEMDFN=0
FOR ADER=0:0
SET ADEMDFN=$ORDER(^ADEFOL("TYPE",ADEPAT,"rc",ADETYP,ADEMDFN))
IF '+ADEMDFN
QUIT
DO MSG
+3 KILL ADETYP,ADEMDFN,ADEQ,ADER,XMB
QUIT
MSG IF '$DATA(^ADEFOL(ADEMDFN,0))
QUIT
+1 KILL XMB
+2 IF $PIECE(^ADEFOL(ADEMDFN,0),U,5)="u"
SET XMB(1)=$PIECE(^DPT(ADEPAT,0),U)
SET XMB(2)=ADEVDATE
IF $PIECE(^ADEFOL(ADEMDFN,0),U,7)]""
IF $DATA(^DIC(16,$PIECE(^ADEFOL(ADEMDFN,0),U,7),0))
SET XMB(3)=$PIECE(^DIC(16,$PIECE(^ADEFOL(ADEMDFN,0),U,7),0),U)
+3 IF $DATA(XMB)
Begin DoDot:1
+4 SET XMB="ADECALL"
+5 SET XMDUZ="DENTAL RECALL SYSTEM"
+6 DO ^XMB
+7 KILL XMB
End DoDot:1
+8 QUIT
