ADEPENDA.m

ADEPENDA ; IHS/HQT/MJL  - ENDO REPORT PT 2 ;09:45 AM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

GRP ;EP - Sets up code and opsite groups

 S ADECOD("ACCESSED")=$$ADACOD("3300,3301,3302,3303")

 S ADECOD("EXTRACTED")=$$ADACOD($$GROUP("EXTRACTIONS"))

 S ADECOD("COMPLETED")=$$ADACOD("3310,3311,3320,3321,3330,3331")

 S ADECOD("RESTORED")=$$ADACOD($$GROUP("RESTORATIONS-PERMANENT TOOTH"))

 S ADECOD("CROWNED")=$$ADACOD($$GROUP("CROWNS-PERMANENT TOOTH"))

 S ADEOP("FIRST MOLARS")=$$OPCOD("3,14,19,30")

 S ADEOP("PREMOLARS")=$$OPCOD($$GROUP("PERMANENT PREMOLARS"))

 S ADEOP("ANTERIORS")=$$OPCOD($$GROUP("PERMANENT ANTERIORS"))

 S ADEOP("OTHER MOLARS")=$$OPCOD("1,2,15,16,17,18,31,32")

 Q

 ;

GROUP(ADENAM) ;EP - Retuns code group ADENAM from ^ADEDIT("GRP")

 ;And translates any |'s to commas

 S ADENAM=$O(^ADEDIT("GRP","B",ADENAM,0))

 S ADENAM=$P(^ADEDIT("GRP",ADENAM,1),U)

 S ADENAM=$TR(ADENAM,"|",",")

 Q ADENAM

 ;

ADACOD(ADECOD) ;EP - Given "ADA CODE,ADA CODE,...ADA CODE"

 ;Returns "COD DFN,CODE DFN,...CODE DFN"

 N ADEDFN,ADEJ,ADEPC

 S ADEDFN=""

 F ADEJ=1:1:$L(ADECOD,",") S ADEPC=$P(ADECOD,",",ADEJ) D

 . S ADEPC=$O(^AUTTADA("B",ADEPC,0))

 . Q:ADEPC=""

 . I ADEDFN="" S ADEDFN=ADEPC Q

 . S $P(ADEDFN,",",ADEJ)=ADEPC

 Q ADEDFN

 ;

OPCOD(ADEOP) ;EP - Given "OPSITE,OPSITE,...OPSITE"

 ;Returns "OP DFN,OP DFN,...OP DFN"

 N ADEDFN,ADEJ,ADEPC

 S ADEDFN=""

 F ADEJ=1:1:$L(ADEOP,",") S ADEPC=$P(ADEOP,",",ADEJ) D

 . S ADEPC=$O(^ADEOPS("B",ADEPC,0))

 . Q:ADEPC=""

 . I ADEDFN="" S ADEDFN=ADEPC Q

 . S $P(ADEDFN,",",ADEJ)=ADEPC

 Q ADEDFN

DDS() ;EP

 ;Returns "1/0^DFN,DFN,DFN"

 ;ALSO SETS UP ARRAY ADEHNAM(DFN)="DENTIST,NAME"

 N ADEHYG,ADEJ

 S ADEHYG=""

 S ADEJ=0

 F  S ADEJ=$O(^DIC(6,ADEJ)) Q:'+ADEJ  D

 . I $P(^DIC(6,ADEJ,0),U,4)]"",$D(^DIC(7,$P(^DIC(6,ADEJ,0),U,4),9999999)),+^DIC(7,$P(^DIC(6,ADEJ,0),U,4),9999999)=52 D

 . . I ADEHYG="" S ADEHYG=ADEJ Q

 . . S $P(ADEHYG,",",$L(ADEHYG,",")+1)=ADEJ

 I ADEHYG="" Q 0

 F ADEJ=1:1:$L(ADEHYG,",") S ADEHNAM($P(ADEHYG,",",ADEJ))=$P(^DIC(16,$P(ADEHYG,",",ADEJ),0),U)

 S ADEHYG="1^"_ADEHYG

 Q ADEHYG

 ;

ADEU() ;GET UNIQUE SUBSCRIPT NUMBER AND LOCK REPORT NODE

 ;RETURNS SUBSCRIPT NUMBER

 S ADEU=$J

ADEU1 F  L +^TMP("ADEPEND",ADEU):.1 Q:$T  S ADEU=ADEU+1

 I $G(^TMP("ADEPEND",ADEU))="RUNNING" L -^TMP("ADEPEND",ADEU) S ADEU=ADEU+1 G ADEU1

 S ^TMP("ADEPEND",ADEU)="RUNNING"

 ; ^TMP is a transient, non-fileman working global.

 Q ADEU

 ;

ASKDEV(ADERTN,ADEDESC) ;EP - DEVICE SELECTION

 ;ADERTN=TASKMAN PROCESSING ROUTINE ENTRY POINT

 ;ADEDESC=TASK DESCRIPTION

 ;RETURNS ADEIOP,ADEIOPAR

 K ADEIOP,IOP,ZTSK,ADEIOPAR

 W !!,"Enter 'Q' at the DEVICE prompt to queue this report to run in the background."

 S %ZIS="NQ"

 D ^%ZIS

 Q:POP

 S ADEIOP=ION_";"_IOM_";"_IOSL

 S ADEIOPAR=IOPAR

 Q:'$D(IO("Q"))

 D QUE

 ;FHL 9/9/98 I '$D(ZTSK) K IOP,ADEIOP,ADEIOPAR G ASKDEV

 I '$D(ZTQUEUED) K IOP,ADEIOP,ADEIOPAR G ASKDEV

 D HOME^%ZIS

 W !,"REPORT IS QUEUED!"

 Q

 ;

QUE ;

 N ADEJ

 S ZTRTN=ADERTN

 S ZTDESC=ADEDESC

 F ADEJ="ADEIOP","ADEDATE" S ZTSAVE(ADEJ)=""

 S ZTSAVE("ADEIOPAR")=""

 S ZTSAVE("ADEU")=""

 S ZTIO=""

 I $D(IO("HFSIO")) D

 . S ZTIO=ADEIOP

 D ^%ZTLOAD

 Q

 ;

KILL ;EP - KILLS

 K ADEADA,ADEAGE,ADECNT,ADECOD,ADED0,ADED1,ADED2,ADEDATE

 K ADEDFN,ADEDUZ,ADEEXT,ADEHDFN,ADEHDFNS,ADEHNAM,ADEHYG,ADEJ,ADEK,ADEL

 K ADELOC,ADENAM,ADEOP,ADEPC,ADEPROV,ADEREP,ADEROPT,ADESTP,ADETDFN

 K ADETNAM,ADEIOPAR,ADEDESC,ADERTN,ADEU,ADEZTSK

 K ADEHXC,ADEHXO

 K ADENOD

 Q

ADEPENDA  ; IHS/HQT/MJL  - ENDO REPORT PT 2 ;09:45 AM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

GRP       ;EP - Sets up code and opsite groups

 +1        SET ADECOD("ACCESSED")=$$ADACOD("3300,3301,3302,3303")

 +2        SET ADECOD("EXTRACTED")=$$ADACOD($$GROUP("EXTRACTIONS"))

 +3        SET ADECOD("COMPLETED")=$$ADACOD("3310,3311,3320,3321,3330,3331")

 +4        SET ADECOD("RESTORED")=$$ADACOD($$GROUP("RESTORATIONS-PERMANENT TOOTH"))

 +5        SET ADECOD("CROWNED")=$$ADACOD($$GROUP("CROWNS-PERMANENT TOOTH"))

 +6        SET ADEOP("FIRST MOLARS")=$$OPCOD("3,14,19,30")

 +7        SET ADEOP("PREMOLARS")=$$OPCOD($$GROUP("PERMANENT PREMOLARS"))

 +8        SET ADEOP("ANTERIORS")=$$OPCOD($$GROUP("PERMANENT ANTERIORS"))

 +9        SET ADEOP("OTHER MOLARS")=$$OPCOD("1,2,15,16,17,18,31,32")

 +10       QUIT 

 +11      ;

GROUP(ADENAM) ;EP - Retuns code group ADENAM from ^ADEDIT("GRP")

 +1       ;And translates any |'s to commas

 +2        SET ADENAM=$ORDER(^ADEDIT("GRP","B",ADENAM,0))

 +3        SET ADENAM=$PIECE(^ADEDIT("GRP",ADENAM,1),U)

 +4        SET ADENAM=$TRANSLATE(ADENAM,"|",",")

 +5        QUIT ADENAM

 +6       ;

ADACOD(ADECOD) ;EP - Given "ADA CODE,ADA CODE,...ADA CODE"

 +1       ;Returns "COD DFN,CODE DFN,...CODE DFN"

 +2        NEW ADEDFN,ADEJ,ADEPC

 +3        SET ADEDFN=""

 +4        FOR ADEJ=1:1:$LENGTH(ADECOD,",")

               SET ADEPC=$PIECE(ADECOD,",",ADEJ)

               Begin DoDot:1

 +5                SET ADEPC=$ORDER(^AUTTADA("B",ADEPC,0))

 +6                IF ADEPC=""

                       QUIT 

 +7                IF ADEDFN=""

                       SET ADEDFN=ADEPC

                       QUIT 

 +8                SET $PIECE(ADEDFN,",",ADEJ)=ADEPC

               End DoDot:1

 +9        QUIT ADEDFN

 +10      ;

OPCOD(ADEOP) ;EP - Given "OPSITE,OPSITE,...OPSITE"

 +1       ;Returns "OP DFN,OP DFN,...OP DFN"

 +2        NEW ADEDFN,ADEJ,ADEPC

 +3        SET ADEDFN=""

 +4        FOR ADEJ=1:1:$LENGTH(ADEOP,",")

               SET ADEPC=$PIECE(ADEOP,",",ADEJ)

               Begin DoDot:1

 +5                SET ADEPC=$ORDER(^ADEOPS("B",ADEPC,0))

 +6                IF ADEPC=""

                       QUIT 

 +7                IF ADEDFN=""

                       SET ADEDFN=ADEPC

                       QUIT 

 +8                SET $PIECE(ADEDFN,",",ADEJ)=ADEPC

               End DoDot:1

 +9        QUIT ADEDFN

DDS()     ;EP

 +1       ;Returns "1/0^DFN,DFN,DFN"

 +2       ;ALSO SETS UP ARRAY ADEHNAM(DFN)="DENTIST,NAME"

 +3        NEW ADEHYG,ADEJ

 +4        SET ADEHYG=""

 +5        SET ADEJ=0

 +6        FOR 

               SET ADEJ=$ORDER(^DIC(6,ADEJ))

               IF '+ADEJ

                   QUIT 

               Begin DoDot:1

 +7                IF $PIECE(^DIC(6,ADEJ,0),U,4)]""

                       IF $DATA(^DIC(7,$PIECE(^DIC(6,ADEJ,0),U,4),9999999))

                           IF +^DIC(7,$PIECE(^DIC(6,ADEJ,0),U,4),9999999)=52

                               Begin DoDot:2

 +8                                IF ADEHYG=""

                                       SET ADEHYG=ADEJ

                                       QUIT 

 +9                                SET $PIECE(ADEHYG,",",$LENGTH(ADEHYG,",")+1)=ADEJ

                               End DoDot:2

               End DoDot:1

 +10       IF ADEHYG=""

               QUIT 0

 +11       FOR ADEJ=1:1:$LENGTH(ADEHYG,",")

               SET ADEHNAM($PIECE(ADEHYG,",",ADEJ))=$PIECE(^DIC(16,$PIECE(ADEHYG,",",ADEJ),0),U)

 +12       SET ADEHYG="1^"_ADEHYG

 +13       QUIT ADEHYG

 +14      ;

ADEU()    ;GET UNIQUE SUBSCRIPT NUMBER AND LOCK REPORT NODE

 +1       ;RETURNS SUBSCRIPT NUMBER

 +2        SET ADEU=$JOB

ADEU1      FOR 

               LOCK +^TMP("ADEPEND",ADEU):.1

               IF $TEST

                   QUIT 

               SET ADEU=ADEU+1

 +1        IF $GET(^TMP("ADEPEND",ADEU))="RUNNING"

               LOCK -^TMP("ADEPEND",ADEU)

               SET ADEU=ADEU+1

               GOTO ADEU1

 +2        SET ^TMP("ADEPEND",ADEU)="RUNNING"

 +3       ; ^TMP is a transient, non-fileman working global.

 +4        QUIT ADEU

 +5       ;

ASKDEV(ADERTN,ADEDESC) ;EP - DEVICE SELECTION

 +1       ;ADERTN=TASKMAN PROCESSING ROUTINE ENTRY POINT

 +2       ;ADEDESC=TASK DESCRIPTION

 +3       ;RETURNS ADEIOP,ADEIOPAR

 +4        KILL ADEIOP,IOP,ZTSK,ADEIOPAR

 +5        WRITE !!,"Enter 'Q' at the DEVICE prompt to queue this report to run in the background."

 +6        SET %ZIS="NQ"

 +7        DO ^%ZIS

 +8        IF POP

               QUIT 

 +9        SET ADEIOP=ION_";"_IOM_";"_IOSL

 +10       SET ADEIOPAR=IOPAR

 +11       IF '$DATA(IO("Q"))

               QUIT 

 +12       DO QUE

 +13      ;FHL 9/9/98 I '$D(ZTSK) K IOP,ADEIOP,ADEIOPAR G ASKDEV

 +14       IF '$DATA(ZTQUEUED)

               KILL IOP,ADEIOP,ADEIOPAR

               GOTO ASKDEV

 +15       DO HOME^%ZIS

 +16       WRITE !,"REPORT IS QUEUED!"

 +17       QUIT 

 +18      ;

QUE       ;

 +1        NEW ADEJ

 +2        SET ZTRTN=ADERTN

 +3        SET ZTDESC=ADEDESC

 +4        FOR ADEJ="ADEIOP","ADEDATE"

               SET ZTSAVE(ADEJ)=""

 +5        SET ZTSAVE("ADEIOPAR")=""

 +6        SET ZTSAVE("ADEU")=""

 +7        SET ZTIO=""

 +8        IF $DATA(IO("HFSIO"))

               Begin DoDot:1

 +9                SET ZTIO=ADEIOP

               End DoDot:1

 +10       DO ^%ZTLOAD

 +11       QUIT 

 +12      ;

KILL      ;EP - KILLS

 +1        KILL ADEADA,ADEAGE,ADECNT,ADECOD,ADED0,ADED1,ADED2,ADEDATE

 +2        KILL ADEDFN,ADEDUZ,ADEEXT,ADEHDFN,ADEHDFNS,ADEHNAM,ADEHYG,ADEJ,ADEK,ADEL

 +3        KILL ADELOC,ADENAM,ADEOP,ADEPC,ADEPROV,ADEREP,ADEROPT,ADESTP,ADETDFN

 +4        KILL ADETNAM,ADEIOPAR,ADEDESC,ADERTN,ADEU,ADEZTSK

 +5        KILL ADEHXC,ADEHXO

 +6        KILL ADENOD

 +7        QUIT