- 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