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
