Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ADEPEND

ADEPEND.m

Go to the documentation of this file.
  1. ADEPEND ; IHS/HQT/MJL - ENDO REPORT ;11:43 AM [ 03/24/1999 9:04 AM ]
  1. ;;6.0;ADE;;APRIL 1999
  1. ;
  1. N ADEDATE,DIR,ADEIOP,ADEU
  1. S ADEDATE=$$DATE^ADEPQA3() G:$$HAT^ADEPQA() END
  1. ;
  1. ;GET AND LOCK UNIQUE SUBSCRIPT FOR REPORT GLOBAL
  1. S ADEU=$$ADEU^ADEPENDA()
  1. K ^TMP("ADEPEND",ADEU) ;^TMP is a transient report global
  1. S ^TMP("ADEPEND",ADEU)="RUNNING"
  1. ;
  1. D ASKDEV^ADEPENDA("ZTM^ADEPEND","ENDODONTIC REPORT PROCESSING")
  1. I POP K ^TMP("ADEPEND",ADEU) G END
  1. ;FHL 9/9/98 I $D(ZTSK) G END
  1. I $D(ZTQUEUED) G END
  1. ;
  1. ZTM ;EP - TASKMAN PROCESSING ENTRY POINT
  1. N ADESTP,ADEAGE,ADEPROV,ADEHYG,ADELOC,ADEADA,ADEEXT,ADEHDFNS,ADEHDFN,ADEHNAM,ADEROPT,ADEL,ADECOD,ADEOP,ADETNAM,ADETDFN
  1. I $D(ZTQUEUED) L +^TMP("ADEPEND",ADEU):1 I '$T S ZTREQ="@" G END
  1. ;
  1. S (ADESTP,ADEAGE,ADEPROV,ADEHYG,ADELOC)=0
  1. K ^ADEUTL("ADEPQA",$J)
  1. D GRP^ADEPENDA
  1. S ADEROPT="4^DENTAL"
  1. S ADEADA(1)="1^"_ADECOD("ACCESSED")_"^^^^^"
  1. S ADETNAM="ADEQAENDO"_$P($H,",",2)
  1. I $D(^DIBT("B",ADETNAM)) D ;If template exists, delete it
  1. . S ADETDFN=$O(^DIBT("B",ADETNAM,0))
  1. . D DELTMP^ADEPQA(ADETDFN)
  1. S ADETDFN=$$TMPLAT^ADEPQA(ADETNAM,9002007) ;create template
  1. S ADEEXT=1
  1. D ROLL^ADEPQA
  1. ;
  1. S ADESTP="1^"_ADETDFN_"^"_9002007
  1. I '$D(^DIBT(ADETDFN,1)) D G END ;No Endo Accesses
  1. . I $D(ZTQUEUED) S ZTREQ="@"
  1. . K ^TMP("ADEPEND",ADEU)
  1. . D DELTMP^ADEPQA(ADETDFN)
  1. ;
  1. S ADEL=0 F S ADEL=$O(^DIBT(ADETDFN,1,ADEL)) Q:'+ADEL D
  1. . S ADEHDFNS($P(^ADEPCD(ADEL,0),U,4))=""
  1. S ADEL=0,ADEHDFNS="" F S ADEL=$O(ADEHDFNS(ADEL)) Q:'+ADEL D
  1. . I ADEHDFNS="" S ADEHDFNS=ADEL,ADEHNAM(ADEL)=$P(^DIC(16,ADEL,0),U) Q
  1. . S $P(ADEHDFNS,",",$L(ADEHDFNS,",")+1)=ADEL,ADEHNAM(ADEL)=$P(^DIC(16,ADEL,0),U)
  1. S ADEPROV=1
  1. F ADEL=1:1:$L(ADEHDFNS,",") S ADEHDFN=$P(ADEHDFNS,",",ADEL),$P(ADEPROV,U,2)=ADEHDFN D TEMROLL
  1. K ^ADEUTL("ADEPQA",$J)
  1. D DELTMP^ADEPQA(ADETDFN)
  1. ;
  1. I $D(ZTQUEUED) D G END
  1. . I $D(IOT),IOT'="HFS" D Q
  1. . . S ZTREQ=$H_U_ADEIOP_U_"ENDODONTIC REPORT PRINTING"_U_"PRINT^ADEPEND"
  1. . D PRINT Q
  1. ;
  1. D PRINT
  1. ;
  1. END I $D(ADEU) L -^TMP("ADEPEND",ADEU)
  1. D KILL^ADEPENDA
  1. Q
  1. ;
  1. ;------->SUBROUTINES
  1. ;
  1. TEMROLL ;
  1. N ADEDFN
  1. S ADEDFN=0
  1. F S ADEDFN=$O(^DIBT(ADETDFN,1,ADEDFN)) Q:'+ADEDFN D
  1. . I $P(^ADEPCD(ADEDFN,0),U,4)=ADEHDFN S ADENOD=^ADEPCD(ADEDFN,0) D CALL
  1. Q
  1. ;
  1. CALL ;FOR ADEADA(1) = accessed, accessed + extracted,
  1. ; +completed, +alloy restored, +crown restored
  1. N ADEJ,ADEK,ADEL,ADEPC
  1. S ADEADA(1)="1^"_ADECOD("ACCESSED")_"^^^^^"
  1. F ADEPC=1:1:5 D
  1. . I ADEPC>1 S $P(ADEADA(1),U,6)="Y",$P(ADEADA(1),U,5)=99999
  1. . I ADEPC=3 S $P(ADEADA(1),U,3)=ADECOD("EXTRACTED")
  1. . I ADEPC=2 S $P(ADEADA(1),U,3)=ADECOD("COMPLETED")
  1. . I ADEPC=4 S $P(ADEADA(1),U,3)=ADECOD("RESTORED")
  1. . I ADEPC=5 S $P(ADEADA(1),U,3)=ADECOD("CROWNED")
  1. . D CALL2
  1. Q
  1. CALL2 F ADEOP=1:1:4 D
  1. . I ADEOP=1 S $P(ADEADA(1),U,7)=ADEOP("FIRST MOLARS")
  1. . I ADEOP=2 S $P(ADEADA(1),U,7)=ADEOP("OTHER MOLARS")
  1. . I ADEOP=3 S $P(ADEADA(1),U,7)=ADEOP("PREMOLARS")
  1. . I ADEOP=4 S $P(ADEADA(1),U,7)=ADEOP("ANTERIORS")
  1. . I ADEPC=1 D D CALL1 Q
  1. . . I '$D(^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$S(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS"))) D
  1. . . . 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"
  1. . I +^TMP("ADEPEND",ADEU,ADEHNAM(ADEHDFN),$S(ADEOP=1:"FIRST MOLARS",ADEOP=2:"OTHER MOLARS",ADEOP=3:"PREMOLARS",1:"ANTERIORS")) D CALL1
  1. Q
  1. CALL1 N ADECNT,ADEJ,ADEK
  1. K ^ADEUTL("ADEPQA",$J)
  1. Q:'$$CODSCN^ADEPQA1D(ADEDFN)
  1. ;After search, count entries in ADEUTL("ADEPQA",$J)
  1. S (ADECNT,ADEJ)=0 F S ADEJ=$O(^ADEUTL("ADEPQA",$J,ADEJ)) Q:'+ADEJ D
  1. . S ADEK=0 F S ADEK=$O(^ADEUTL("ADEPQA",$J,ADEJ,ADEK)) Q:'+ADEK S ADECNT=ADECNT+1
  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
  1. ;^TMP("ADEPEND",ADEU,"DENTIST NAME","TOOTH CAT.")="Total Accessed^+extracted^+completed^+alloy restored^+crown restored"
  1. Q
  1. ;
  1. PRINT ;(See note at label PRINT in ADEPENDN)
  1. ;
  1. I '$D(^TMP("ADEPEND",ADEU)) G PRNEND
  1. I $O(^TMP("ADEPEND",ADEU,0))="" G PRNEND
  1. I $D(ZTQUEUED) L +^TMP("ADEPEND",ADEU):1 I '$T S ADENOLOK=1 G PRNEND
  1. N DIC,BY,FLDS,ADED0,ADED1,ADED2,DHD,Y,ADEDUZ,ADEZTSK
  1. S IOP=ADEIOP
  1. S %ZIS("IOPAR")=ADEIOPAR
  1. D ^%ZIS
  1. S IOP=ADEIOP
  1. S %ZIS("IOPAR")=ADEIOPAR
  1. S DIC="^ADEDUM(",BY="@NUMBER",(FR,TO)="",FLDS="[ADEP-ADEPEND]"
  1. S ADED0=0,ADED1=0
  1. S DHD=$O(^ADEPARAM(0)),DHD=$P(^ADEPARAM(DHD,0),U),DHD=$P(^DIC(4,DHD,0),U)
  1. S DHD=DHD_": ENDODONTIC TOOTH ACCESS"
  1. S Y=$P(ADEDATE,U,2) X ^DD("DD") S DHD=DHD_" ("_Y
  1. S Y=$P(ADEDATE,U,3) X ^DD("DD") S DHD=DHD_"-"_Y_")"
  1. ;FHL 9/9/98 I $D(ZTSK) S ADEZTSK=ZTSK K ZTSK
  1. I $D(ZTQUED) S ADEZTSK=ZTSK K ZTSK
  1. D EN1^DIP
  1. I $D(ADEZTSK) S ZTSK=ADEZTSK
  1. PRNEND I $D(ZTQUEUED) S ZTREQ="@"
  1. I '$D(ADENOLOK) K ^TMP("ADEPEND",ADEU)
  1. K ADENOLOK
  1. Q