- 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 Mar 13, 2025@21:03:45 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
