ECSUM2 ;BIR/JLP,RHK-Category and Procedure Summary (cont'd) ;20 Mar 96
;;2.0; EVENT CAPTURE ;**4,19,23,104**;8 May 96;Build 7
;Prints Categories and Procedures for a DSS Unit
START S ECPG=1,ECMORE=0 D HEADER I ECC="ALL" D CATS G END
I 'ECJLP S ECC=0,ECCN="None"
CAT ;
W !!,?3,"Category: "_ECCN D:$Y+4>IOSL PAGE,HEADER:ECPG Q:ECOUT D PROC
END S ECPG=1
Q
SETC ;set cats
I ECC=0 S ECCN="None" Q
S ECCN=$S($P($G(^EC(726,+ECC,0)),"^")]"":$P(^(0),"^"),1:"ZZ #"_ECC_" MISSING DATA")
S ECMORE=1
Q
W:$E(IOST,1,2)="C-"!(ECPG>1) @IOF S ECPG=ECPG+1
W !!,?25,"CATEGORY AND PROCEDURE SUMMARY",!,?25,"Run Date : ",ECRDT W !,?25,"LOCATION: "_ECLN,!,?25,"SERVICE: "_ECSN,!,?25,"DSS UNIT: "_ECDN,! F I=1:1:80 W "-"
I $D(ECCN) D MORE
Q
CATS ;
S ECC="" F S ECC=$O(^ECJ("AP",ECL,ECD,ECC)) Q:ECC="" D SETC W !!,?3,"Category: "_ECCN D:$Y+4>IOSL PAGE,HEADER:ECPG Q:ECOUT D PROC
S ECMORE=0
Q
PROC ;
S ECP="" F S ECP=$O(^ECJ("AP",ECL,ECD,ECC,ECP)) Q:ECP="" D SETP Q:ECOUT
S ECMORE=0
Q
SETP ;set procs
S ECPSY=+$O(^ECJ("AP",ECL,ECD,ECC,ECP,""))
S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2),EC4=+$P($G(^("PRO")),"^",4)
S EC2="" I EC4 S EC2=$S($P($G(^SC(EC4,0)),"^")]"":$P(^(0),"^"),1:"NO ASSOCIATED CLINIC")
S ECFILE=$P(ECP,";",2),ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"UNKNOWN")
I ECFILE="UNKNOWN" S ECPN="UNKNOWN",NATN="UNKNOWN"
I ECFILE=81 S ECPN=$P($$CPT^ICPTCOD(+ECP),"^",3),ECPN=$S(ECPN]"":ECPN,1:"UNKNOWN"),X=$P($$CPT^ICPTCOD(+ECP),"^",2),NATN=$S(X["NO SUCH ENTRY":"NOT LISTED",X="":"NOT LISTED",1:X)
I ECFILE=725 S ECPN=$S($P($G(^EC(725,+ECP,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),NATN=$S($P($G(^EC(725,+ECP,0)),"^",2)]"":$P(^(0),"^",2),1:"NOT LISTED")
S ECPN=$S(ECPSYN]"":ECPSYN,1:ECPN)
W !,?3,"Procedure: ",$E(ECPN,1,30)," (",$S(ECFILE=81:"CPT",1:"EC"),")",?52,"Nat'l No.: ",NATN
W:EC2]"" !,?14,"(Clinic: "_EC2_")"
I $P($G(^ECJ(+ECPSY,0)),"^",2) W ?70,"*INACTIVE*"
D:$Y+3>IOSL PAGE,HEADER:ECPG Q:ECOUT
Q
PAGE ;
N SS,JJ
I $D(ECPG),$E(IOST,1,2)="C-" D
. S SS=22-$Y F JJ=1:1:SS W !
. S DIR(0)="E" W ! D ^DIR K DIR I 'Y S ECOUT=1
Q
MORE I ECMORE W !!,?3,"Category: "_ECCN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECSUM2 2170 printed Oct 16, 2024@17:59:39 Page 2
ECSUM2 ;BIR/JLP,RHK-Category and Procedure Summary (cont'd) ;20 Mar 96
+1 ;;2.0; EVENT CAPTURE ;**4,19,23,104**;8 May 96;Build 7
+2 ;Prints Categories and Procedures for a DSS Unit
START SET ECPG=1
SET ECMORE=0
DO HEADER
IF ECC="ALL"
DO CATS
GOTO END
+1 IF 'ECJLP
SET ECC=0
SET ECCN="None"
CAT ;
+1 WRITE !!,?3,"Category: "_ECCN
if $Y+4>IOSL
DO PAGE
if ECPG
DO HEADER
if ECOUT
QUIT
DO PROC
END SET ECPG=1
+1 QUIT
SETC ;set cats
+1 IF ECC=0
SET ECCN="None"
QUIT
+2 SET ECCN=$SELECT($PIECE($GET(^EC(726,+ECC,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ #"_ECC_" MISSING DATA")
+3 SET ECMORE=1
+4 QUIT
+1 if $EXTRACT(IOST,1,2)="C-"!(ECPG>1)
WRITE @IOF
SET ECPG=ECPG+1
+2 WRITE !!,?25,"CATEGORY AND PROCEDURE SUMMARY",!,?25,"Run Date : ",ECRDT
WRITE !,?25,"LOCATION: "_ECLN,!,?25,"SERVICE: "_ECSN,!,?25,"DSS UNIT: "_ECDN,!
FOR I=1:1:80
WRITE "-"
+3 IF $DATA(ECCN)
DO MORE
+4 QUIT
CATS ;
+1 SET ECC=""
FOR
SET ECC=$ORDER(^ECJ("AP",ECL,ECD,ECC))
if ECC=""
QUIT
DO SETC
WRITE !!,?3,"Category: "_ECCN
if $Y+4>IOSL
DO PAGE
if ECPG
DO HEADER
if ECOUT
QUIT
DO PROC
+2 SET ECMORE=0
+3 QUIT
PROC ;
+1 SET ECP=""
FOR
SET ECP=$ORDER(^ECJ("AP",ECL,ECD,ECC,ECP))
if ECP=""
QUIT
DO SETP
if ECOUT
QUIT
+2 SET ECMORE=0
+3 QUIT
SETP ;set procs
+1 SET ECPSY=+$ORDER(^ECJ("AP",ECL,ECD,ECC,ECP,""))
+2 SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
SET EC4=+$PIECE($GET(^("PRO")),"^",4)
+3 SET EC2=""
IF EC4
SET EC2=$SELECT($PIECE($GET(^SC(EC4,0)),"^")]"":$PIECE(^(0),"^"),1:"NO ASSOCIATED CLINIC")
+4 SET ECFILE=$PIECE(ECP,";",2)
SET ECFILE=$SELECT($EXTRACT(ECFILE)="I":81,$EXTRACT(ECFILE)="E":725,1:"UNKNOWN")
+5 IF ECFILE="UNKNOWN"
SET ECPN="UNKNOWN"
SET NATN="UNKNOWN"
+6 IF ECFILE=81
SET ECPN=$PIECE($$CPT^ICPTCOD(+ECP),"^",3)
SET ECPN=$SELECT(ECPN]"":ECPN,1:"UNKNOWN")
SET X=$PIECE($$CPT^ICPTCOD(+ECP),"^",2)
SET NATN=$SELECT(X["NO SUCH ENTRY":"NOT LISTED",X="":"NOT LISTED",1:X)
+7 IF ECFILE=725
SET ECPN=$SELECT($PIECE($GET(^EC(725,+ECP,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
SET NATN=$SELECT($PIECE($GET(^EC(725,+ECP,0)),"^",2)]"":$PIECE(^(0),"^",2),1:"NOT LISTED")
+8 SET ECPN=$SELECT(ECPSYN]"":ECPSYN,1:ECPN)
+9 WRITE !,?3,"Procedure: ",$EXTRACT(ECPN,1,30)," (",$SELECT(ECFILE=81:"CPT",1:"EC"),")",?52,"Nat'l No.: ",NATN
+10 if EC2]""
WRITE !,?14,"(Clinic: "_EC2_")"
+11 IF $PIECE($GET(^ECJ(+ECPSY,0)),"^",2)
WRITE ?70,"*INACTIVE*"
+12 if $Y+3>IOSL
DO PAGE
if ECPG
DO HEADER
if ECOUT
QUIT
+13 QUIT
PAGE ;
+1 NEW SS,JJ
+2 IF $DATA(ECPG)
IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET ECOUT=1
End DoDot:1
+5 QUIT
MORE IF ECMORE
WRITE !!,?3,"Category: "_ECCN
+1 QUIT
