ADEPEND ; IHS/HQT/MJL - ENDO REPORT ;11:43 AM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;
N ADEDATE,DIR,ADEIOP,ADEU
S ADEDATE=$$DATE^ADEPQA3() G:$$HAT^ADEPQA() END
;
;GET AND LOCK UNIQUE SUBSCRIPT FOR REPORT GLOBAL
S ADEU=$$ADEU^ADEPENDA()
K ^TMP("ADEPEND",ADEU) ;^TMP is a transient report global
S ^TMP("ADEPEND",ADEU)="RUNNING"
;
D ASKDEV^ADEPENDA("ZTM^ADEPEND","ENDODONTIC REPORT PROCESSING")
I POP K ^TMP("ADEPEND",ADEU) G END
;FHL 9/9/98 I $D(ZTSK) G END
I $D(ZTQUEUED) G END
;
ZTM ;EP - TASKMAN PROCESSING ENTRY POINT
N ADESTP,ADEAGE,ADEPROV,ADEHYG,ADELOC,ADEADA,ADEEXT,ADEHDFNS,ADEHDFN,ADEHNAM,ADEROPT,ADEL,ADECOD,ADEOP,ADETNAM,ADETDFN
I $D(ZTQUEUED) L +^TMP("ADEPEND",ADEU):1 I '$T S ZTREQ="@" G END
;
S (ADESTP,ADEAGE,ADEPROV,ADEHYG,ADELOC)=0
K ^ADEUTL("ADEPQA",$J)
D GRP^ADEPENDA
S ADEROPT="4^DENTAL"
S ADEADA(1)="1^"_ADECOD("ACCESSED")_"^^^^^"
S ADETNAM="ADEQAENDO"_$P($H,",",2)
I $D(^DIBT("B",ADETNAM)) D ;If template exists, delete it
. S ADETDFN=$O(^DIBT("B",ADETNAM,0))
. D DELTMP^ADEPQA(ADETDFN)
S ADETDFN=$$TMPLAT^ADEPQA(ADETNAM,9002007) ;create template
S ADEEXT=1
D ROLL^ADEPQA
;
S ADESTP="1^"_ADETDFN_"^"_9002007
I '$D(^DIBT(ADETDFN,1)) D G END ;No Endo Accesses
. I $D(ZTQUEUED) S ZTREQ="@"
. K ^TMP("ADEPEND",ADEU)
. D DELTMP^ADEPQA(ADETDFN)
;
S ADEL=0 F S ADEL=$O(^DIBT(ADETDFN,1,ADEL)) Q:'+ADEL D
. S ADEHDFNS($P(^ADEPCD(ADEL,0),U,4))=""
S ADEL=0,ADEHDFNS="" F S ADEL=$O(ADEHDFNS(ADEL)) Q:'+ADEL D
. I ADEHDFNS="" S ADEHDFNS=ADEL,ADEHNAM(ADEL)=$P(^DIC(16,ADEL,0),U) Q
. S $P(ADEHDFNS,",",$L(ADEHDFNS,",")+1)=ADEL,ADEHNAM(ADEL)=$P(^DIC(16,ADEL,0),U)
S ADEPROV=1
F ADEL=1:1:$L(ADEHDFNS,",") S ADEHDFN=$P(ADEHDFNS,",",ADEL),$P(ADEPROV,U,2)=ADEHDFN D TEMROLL
K ^ADEUTL("ADEPQA",$J)
D DELTMP^ADEPQA(ADETDFN)
;
I $D(ZTQUEUED) D G END
. I $D(IOT),IOT'="HFS" D Q
. . S ZTREQ=$H_U_ADEIOP_U_"ENDODONTIC REPORT PRINTING"_U_"PRINT^ADEPEND"
. D PRINT Q
;
D PRINT
;
END I $D(ADEU) L -^TMP("ADEPEND",ADEU)
D KILL^ADEPENDA
Q
;
;------->SUBROUTINES
;
TEMROLL ;
N ADEDFN
S ADEDFN=0
F S ADEDFN=$O(^DIBT(ADETDFN,1,ADEDFN)) Q:'+ADEDFN D
. I $P(^ADEPCD(ADEDFN,0),U,4)=ADEHDFN S ADENOD=^ADEPCD(ADEDFN,0) D CALL
Q
;
CALL ;FOR ADEADA(1) = accessed, accessed + extracted,
; +completed, +alloy restored, +crown restored
N ADEJ,ADEK,ADEL,ADEPC
S ADEADA(1)="1^"_ADECOD("ACCESSED")_"^^^^^"
F ADEPC=1:1:5 D
. I ADEPC>1 S $P(ADEADA(1),U,6)="Y",$P(ADEADA(1),U,5)=99999
. I ADEPC=3 S $P(ADEADA(1),U,3)=ADECOD("EXTRACTED")
. I ADEPC=2 S $P(ADEADA(1),U,3)=ADECOD("COMPLETED")
. I ADEPC=4 S $P(ADEADA(1),U,3)=ADECOD("RESTORED")
. I ADEPC=5 S $P(ADEADA(1),U,3)=ADECOD("CROWNED")
. D CALL2
Q
CALL2 F ADEOP=1:1:4 D
. I ADEOP=1 S $P(ADEADA(1),U,7)=ADEOP("FIRST MOLARS")
. I ADEOP=2 S $P(ADEADA(1),U,7)=ADEOP("OTHER MOLARS")
. I ADEOP=3 S $P(ADEADA(1),U,7)=ADEOP("PREMOLARS")
. I ADEOP=4 S $P(ADEADA(1),U,7)=ADEOP("ANTERIORS")
. I ADEPC=1 D D CALL1 Q
. . I '$D(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$S(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS"))) D
. . . S ^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$S(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS"))="0^0^0^0^0"
. I +^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$S(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS")) D CALL1
Q
CALL1 N ADECNT,ADEJ,ADEK
K ^ADEUTL("ADEPQA",$J)
Q:'$$CODSCN^ADEPQA1D(ADEDFN)
;After search, count entries in ADEUTL("ADEPQA",$J)
S (ADECNT,ADEJ)=0 F S ADEJ=$O(^ADEUTL("ADEPQA",$J,ADEJ)) Q:'+ADEJ D
. S ADEK=0 F S ADEK=$O(^ADEUTL("ADEPQA",$J,ADEJ,ADEK)) Q:'+ADEK S ADECNT=ADECNT+1
S $P(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$P("FIRST MOLARS,OTHER MOLARS,PREMOLARS,ANTERIORS",",",ADEOP)),U,ADEPC)=$P(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$P("FIRST MOLARS,OTHER MOLARS,PREMOLARS,ANTERIORS",",",ADEOP)),U,ADEPC)+ADECNT
;^TMP("ADEPEND",ADEU,"DENTIST NAME","TOOTH CAT.")="Total Accessed^+extracted^+completed^+alloy restored^+crown restored"
Q
;
PRINT ;(See note at label PRINT in ADEPENDN)
;
I '$D(^TMP("ADEPEND",ADEU)) G PRNEND
I $O(^TMP("ADEPEND",ADEU,0))="" G PRNEND
I $D(ZTQUEUED) L +^TMP("ADEPEND",ADEU):1 I '$T S ADENOLOK=1 G PRNEND
N DIC,BY,FLDS,ADED0,ADED1,ADED2,DHD,Y,ADEDUZ,ADEZTSK
S IOP=ADEIOP
S %ZIS("IOPAR")=ADEIOPAR
D ^%ZIS
S IOP=ADEIOP
S %ZIS("IOPAR")=ADEIOPAR
S DIC="^ADEDUM(",BY="@NUMBER",(FR,TO)="",FLDS="[ADEP-ADEPEND]"
S ADED0=0,ADED1=0
S DHD=$O(^ADEPARAM(0)),DHD=$P(^ADEPARAM(DHD,0),U),DHD=$P(^DIC(4,DHD,0),U)
S DHD=DHD_": ENDODONTIC TOOTH ACCESS"
S Y=$P(ADEDATE,U,2) X ^DD("DD") S DHD=DHD_" ("_Y
S Y=$P(ADEDATE,U,3) X ^DD("DD") S DHD=DHD_"-"_Y_")"
;FHL 9/9/98 I $D(ZTSK) S ADEZTSK=ZTSK K ZTSK
I $D(ZTQUED) S ADEZTSK=ZTSK K ZTSK
D EN1^DIP
I $D(ADEZTSK) S ZTSK=ADEZTSK
PRNEND I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ADENOLOK) K ^TMP("ADEPEND",ADEU)
K ADENOLOK
Q
ADEPEND ; IHS/HQT/MJL - ENDO REPORT ;11:43 AM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;
+3 NEW ADEDATE,DIR,ADEIOP,ADEU
+4 SET ADEDATE=$$DATE^ADEPQA3()
IF $$HAT^ADEPQA()
GOTO END
+5 ;
+6 ;GET AND LOCK UNIQUE SUBSCRIPT FOR REPORT GLOBAL
+7 SET ADEU=$$ADEU^ADEPENDA()
+8 ;^TMP is a transient report global
KILL ^TMP("ADEPEND",ADEU)
+9 SET ^TMP("ADEPEND",ADEU)="RUNNING"
+10 ;
+11 DO ASKDEV^ADEPENDA("ZTM^ADEPEND","ENDODONTIC REPORT PROCESSING")
+12 IF POP
KILL ^TMP("ADEPEND",ADEU)
GOTO END
+13 ;FHL 9/9/98 I $D(ZTSK) G END
+14 IF $DATA(ZTQUEUED)
GOTO END
+15 ;
ZTM ;EP - TASKMAN PROCESSING ENTRY POINT
+1 NEW ADESTP,ADEAGE,ADEPROV,ADEHYG,ADELOC,ADEADA,ADEEXT,ADEHDFNS,ADEHDFN,ADEHNAM,ADEROPT,ADEL,ADECOD,ADEOP,ADETNAM,ADETDFN
+2 IF $DATA(ZTQUEUED)
LOCK +^TMP("ADEPEND",ADEU):1
IF '$TEST
SET ZTREQ="@"
GOTO END
+3 ;
+4 SET (ADESTP,ADEAGE,ADEPROV,ADEHYG,ADELOC)=0
+5 KILL ^ADEUTL("ADEPQA",$JOB)
+6 DO GRP^ADEPENDA
+7 SET ADEROPT="4^DENTAL"
+8 SET ADEADA(1)="1^"_ADECOD("ACCESSED")_"^^^^^"
+9 SET ADETNAM="ADEQAENDO"_$PIECE($HOROLOG,",",2)
+10 ;If template exists, delete it
IF $DATA(^DIBT("B",ADETNAM))
Begin DoDot:1
+11 SET ADETDFN=$ORDER(^DIBT("B",ADETNAM,0))
+12 DO DELTMP^ADEPQA(ADETDFN)
End DoDot:1
+13 ;create template
SET ADETDFN=$$TMPLAT^ADEPQA(ADETNAM,9002007)
+14 SET ADEEXT=1
+15 DO ROLL^ADEPQA
+16 ;
+17 SET ADESTP="1^"_ADETDFN_"^"_9002007
+18 ;No Endo Accesses
IF '$DATA(^DIBT(ADETDFN,1))
Begin DoDot:1
+19 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+20 KILL ^TMP("ADEPEND",ADEU)
+21 DO DELTMP^ADEPQA(ADETDFN)
End DoDot:1
GOTO END
+22 ;
+23 SET ADEL=0
FOR
SET ADEL=$ORDER(^DIBT(ADETDFN,1,ADEL))
IF '+ADEL
QUIT
Begin DoDot:1
+24 SET ADEHDFNS($PIECE(^ADEPCD(ADEL,0),U,4))=""
End DoDot:1
+25 SET ADEL=0
SET ADEHDFNS=""
FOR
SET ADEL=$ORDER(ADEHDFNS(ADEL))
IF '+ADEL
QUIT
Begin DoDot:1
+26 IF ADEHDFNS=""
SET ADEHDFNS=ADEL
SET ADEHNAM(ADEL)=$PIECE(^DIC(16,ADEL,0),U)
QUIT
+27 SET $PIECE(ADEHDFNS,",",$LENGTH(ADEHDFNS,",")+1)=ADEL
SET ADEHNAM(ADEL)=$PIECE(^DIC(16,ADEL,0),U)
End DoDot:1
+28 SET ADEPROV=1
+29 FOR ADEL=1:1:$LENGTH(ADEHDFNS,",")
SET ADEHDFN=$PIECE(ADEHDFNS,",",ADEL)
SET $PIECE(ADEPROV,U,2)=ADEHDFN
DO TEMROLL
+30 KILL ^ADEUTL("ADEPQA",$JOB)
+31 DO DELTMP^ADEPQA(ADETDFN)
+32 ;
+33 IF $DATA(ZTQUEUED)
Begin DoDot:1
+34 IF $DATA(IOT)
IF IOT'="HFS"
Begin DoDot:2
+35 SET ZTREQ=$HOROLOG_U_ADEIOP_U_"ENDODONTIC REPORT PRINTING"_U_"PRINT^ADEPEND"
End DoDot:2
QUIT
+36 DO PRINT
QUIT
End DoDot:1
GOTO END
+37 ;
+38 DO PRINT
+39 ;
END IF $DATA(ADEU)
LOCK -^TMP("ADEPEND",ADEU)
+1 DO KILL^ADEPENDA
+2 QUIT
+3 ;
+4 ;------->SUBROUTINES
+5 ;
TEMROLL ;
+1 NEW ADEDFN
+2 SET ADEDFN=0
+3 FOR
SET ADEDFN=$ORDER(^DIBT(ADETDFN,1,ADEDFN))
IF '+ADEDFN
QUIT
Begin DoDot:1
+4 IF $PIECE(^ADEPCD(ADEDFN,0),U,4)=ADEHDFN
SET ADENOD=^ADEPCD(ADEDFN,0)
DO CALL
End DoDot:1
+5 QUIT
+6 ;
CALL ;FOR ADEADA(1) = accessed, accessed + extracted,
+1 ; +completed, +alloy restored, +crown restored
+2 NEW ADEJ,ADEK,ADEL,ADEPC
+3 SET ADEADA(1)="1^"_ADECOD("ACCESSED")_"^^^^^"
+4 FOR ADEPC=1:1:5
Begin DoDot:1
+5 IF ADEPC>1
SET $PIECE(ADEADA(1),U,6)="Y"
SET $PIECE(ADEADA(1),U,5)=99999
+6 IF ADEPC=3
SET $PIECE(ADEADA(1),U,3)=ADECOD("EXTRACTED")
+7 IF ADEPC=2
SET $PIECE(ADEADA(1),U,3)=ADECOD("COMPLETED")
+8 IF ADEPC=4
SET $PIECE(ADEADA(1),U,3)=ADECOD("RESTORED")
+9 IF ADEPC=5
SET $PIECE(ADEADA(1),U,3)=ADECOD("CROWNED")
+10 DO CALL2
End DoDot:1
+11 QUIT
CALL2 FOR ADEOP=1:1:4
Begin DoDot:1
+1 IF ADEOP=1
SET $PIECE(ADEADA(1),U,7)=ADEOP("FIRST MOLARS")
+2 IF ADEOP=2
SET $PIECE(ADEADA(1),U,7)=ADEOP("OTHER MOLARS")
+3 IF ADEOP=3
SET $PIECE(ADEADA(1),U,7)=ADEOP("PREMOLARS")
+4 IF ADEOP=4
SET $PIECE(ADEADA(1),U,7)=ADEOP("ANTERIORS")
+5 IF ADEPC=1
Begin DoDot:2
+6 IF '$DATA(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$SELECT(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS")))
Begin DoDot:3
+7 SET ^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$SELECT(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS"))="0^0^0^0^0"
End DoDot:3
End DoDot:2
DO CALL1
QUIT
+8 IF +^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$SELECT(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS"))
DO CALL1
End DoDot:1
+9 QUIT
CALL1 NEW ADECNT,ADEJ,ADEK
+1 KILL ^ADEUTL("ADEPQA",$JOB)
+2 IF '$$CODSCN^ADEPQA1D(ADEDFN)
QUIT
+3 ;After search, count entries in ADEUTL("ADEPQA",$J)
+4 SET (ADECNT,ADEJ)=0
FOR
SET ADEJ=$ORDER(^ADEUTL("ADEPQA",$JOB,ADEJ))
IF '+ADEJ
QUIT
Begin DoDot:1
+5 SET ADEK=0
FOR
SET ADEK=$ORDER(^ADEUTL("ADEPQA",$JOB,ADEJ,ADEK))
IF '+ADEK
QUIT
SET ADECNT=ADECNT+1
End DoDot:1
+6 SET $PIECE(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$PIECE("FIRST MOLARS,OTHER MOLARS,PREMOLARS,ANTERIORS",",",ADEOP)),U,ADEPC)=$PIECE(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$PIECE("FIRST MOLARS,OTHER MOLARS,PREMOLARS,ANTERIORS",",",ADEOP)),U,ADEPC)+
ADECNT
+7 ;^TMP("ADEPEND",ADEU,"DENTIST NAME","TOOTH CAT.")="Total Accessed^+extracted^+completed^+alloy restored^+crown restored"
+8 QUIT
+9 ;
PRINT ;(See note at label PRINT in ADEPENDN)
+1 ;
+2 IF '$DATA(^TMP("ADEPEND",ADEU))
GOTO PRNEND
+3 IF $ORDER(^TMP("ADEPEND",ADEU,0))=""
GOTO PRNEND
+4 IF $DATA(ZTQUEUED)
LOCK +^TMP("ADEPEND",ADEU):1
IF '$TEST
SET ADENOLOK=1
GOTO PRNEND
+5 NEW DIC,BY,FLDS,ADED0,ADED1,ADED2,DHD,Y,ADEDUZ,ADEZTSK
+6 SET IOP=ADEIOP
+7 SET %ZIS("IOPAR")=ADEIOPAR
+8 DO ^%ZIS
+9 SET IOP=ADEIOP
+10 SET %ZIS("IOPAR")=ADEIOPAR
+11 SET DIC="^ADEDUM("
SET BY="@NUMBER"
SET (FR,TO)=""
SET FLDS="[ADEP-ADEPEND]"
+12 SET ADED0=0
SET ADED1=0
+13 SET DHD=$ORDER(^ADEPARAM(0))
SET DHD=$PIECE(^ADEPARAM(DHD,0),U)
SET DHD=$PIECE(^DIC(4,DHD,0),U)
+14 SET DHD=DHD_": ENDODONTIC TOOTH ACCESS"
+15 SET Y=$PIECE(ADEDATE,U,2)
XECUTE ^DD("DD")
SET DHD=DHD_" ("_Y
+16 SET Y=$PIECE(ADEDATE,U,3)
XECUTE ^DD("DD")
SET DHD=DHD_"-"_Y_")"
+17 ;FHL 9/9/98 I $D(ZTSK) S ADEZTSK=ZTSK K ZTSK
+18 IF $DATA(ZTQUED)
SET ADEZTSK=ZTSK
KILL ZTSK
+19 DO EN1^DIP
+20 IF $DATA(ADEZTSK)
SET ZTSK=ADEZTSK
PRNEND IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF '$DATA(ADENOLOK)
KILL ^TMP("ADEPEND",ADEU)
+2 KILL ADENOLOK
+3 QUIT
