ECSCPT1 ;ALB/JAM - Event Code Screens with CPT Codes ;9/18/18 15:12
;;2.0;EVENT CAPTURE;**72,95,119,131,139,145**;8 May 96;Build 6
EN ;entry point
N UCNT,ECDO,ECCO,ECNT,ECINDT,ECP0
S (ECMORE,ECNT,ECDO,ECCO)=0,ECPG=$G(ECPG,1),ECCPT=$G(ECCPT,"B")
;Process all DSS Units
I ECALL S ECD=0 D G END
.F S ECD=$O(^ECJ("AP",ECL,ECD)) Q:'ECD D Q:ECOUT
..D SET,CATS,PAGE:'ECOUT&UCNT
;Process a specific DSS Unit
S UCNT=0 D
.I ECC="ALL" D CATS Q
.I 'ECJLP S ECC=0,ECCN="None",ECCO=999
.D PROC
END I 'ECNT,$G(ECPTYP)'="E" W !!!,"Nothing Found." ;119 Nothing to write if exporting
S ECPG=$G(ECPG,1)
Q
SET ;set var
S ECDN=$S($P($G(^ECD(+ECD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),UCNT=0
S ECDN=ECDN_$S($P($G(^ECD(+ECD,0)),"^",6):" **Inactive**",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
W !!,?24,"EVENT CODE SCREENS WITH"
W $S(ECCPT="I":" INACTIVE",ECCPT="A":" ACTIVE",1:"")_" CPT CODES"
W ?70,"Page: ",ECPG,!?25,"Run Date: ",ECRDT,!?25,"LOCATION: "_ECLN
W !?25,"DSS UNIT: "_ECDN,! S ECPG=ECPG+1
F I=1:1:80 W "-"
Q
CATS ;
S ECC="",ECCO=0
F S ECC=$O(^ECJ("AP",ECL,ECD,ECC)) Q:ECC="" D Q:ECOUT ;131 Moved calls to dot structure
.I ECC,'$P(^ECD(ECD,0),U,11) Q ;131 Don't include categories if unit is set to "no categories"
.D SETC,PROC ;131 Moved from for loop
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,"")),ECPI=""
S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2),ECFILE=$P(ECP,";",2)
S ECACIEN=+$P($G(^ECJ(ECPSY,"PRO")),U,4) ;Get clinic IEN
S ECAC=$$GET1^DIQ(44,ECACIEN,.01) ;139 Get associated clinic
S NODE=$G(^ECX(728.44,+ECACIEN,0)) ;145
S ECSC=$P(NODE,U,2) ;145 Stop Code
S ECCSC=$P(NODE,U,3) ;145 Credit Stop Code
S ECCHAR=$$GET1^DIQ(728.441,$P(NODE,U,8),.01) ;145 Char 4 code
S ECMCA=$$GET1^DIQ(728.442,$P(NODE,U,14),.01) ;139,145 Get MCA Labor Code for associated clinic
S ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"")
I ECFILE="" Q
S (ECPN,ECPT,NATN)="",ECPI=0
I ECFILE=81 S ECPI=$$CPT^ICPTCOD(+ECP) I +ECPI>0 D
.S ECPN=$P(ECPI,"^",3),ECPT=$P(ECPI,"^",2),ECINDT=$P(ECPI,"^",7)
I ECFILE=725 D
.S ECP0=$G(^EC(725,+ECP,0)),ECPT="",ECPN=$P(ECP0,"^")
.S NATN=$P(ECP0,"^",2)
.I $P(ECP0,"^",5)'="" S ECPI=$$CPT^ICPTCOD($P(ECP0,"^",5)) I +ECPI>0 D
..S ECPT=$P(ECPI,"^",2),ECINDT=$P(ECPI,"^",7)
I +ECPI<1 Q
I ECCPT="A",'ECINDT Q
I ECCPT="I",ECINDT Q
I $G(ECPTYP)="E" D EXPORT Q ;119 Nothing to write if exporting
I ECD'=ECDO D HEADER S ECDO=ECD
I ECC'=ECCO D S ECCO=ECC I ECOUT Q
.W !!,"Category: "_ECCN D:$Y+4>IOSL CONTD
S ECNT=ECNT+1,UCNT=UCNT+1 ;139
W !,"Procedure: ",$E(ECPN,1,30)," (",$S(ECFILE=81:"CPT",1:"EC"),")",?48,"Nat'l #: ",NATN,?64,"CPT: ",ECPT
I ECCPT="B",'ECINDT W ?70," *I*"
I $G(ECPSYN)'="" W !," Synonym: ",ECPSYN ;139
I $G(ECAC)'="" W !," Associated Clinic: ",ECAC,!," Stop Code: ",ECSC,?19,"Credit Stop: ",ECCSC,?38,"CHAR4: ",ECCHAR,?52,"MCA Labor Code: ",ECMCA ;139,145
D:($Y+3)>IOSL CONTD I ECOUT Q
Q
CONTD ;Check whether to continue or exit
D PAGE I ECOUT Q
D HEADER:ECPG,MORE:$D(ECCN)
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 !!,"Category: "_ECCN
Q
;
EXPORT ;Section added in patch 119
S CNT=CNT+1
S ^TMP($J,"ECRPT",CNT)=ECLN_U_ECDN_U_ECCN_U_ECPT_$S('ECINDT:" **Inactive**",1:"")_U_NATN_U_ECPN_" ("_$S(ECFILE=81:"CPT",1:"EC")_")"_U_ECPSYN_U_ECAC_U_ECSC_U_ECCSC_U_ECCHAR_U_ECMCA ;139,145
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECSCPT1 3766 printed Dec 13, 2024@01:58:49 Page 2
ECSCPT1 ;ALB/JAM - Event Code Screens with CPT Codes ;9/18/18 15:12
+1 ;;2.0;EVENT CAPTURE;**72,95,119,131,139,145**;8 May 96;Build 6
EN ;entry point
+1 NEW UCNT,ECDO,ECCO,ECNT,ECINDT,ECP0
+2 SET (ECMORE,ECNT,ECDO,ECCO)=0
SET ECPG=$GET(ECPG,1)
SET ECCPT=$GET(ECCPT,"B")
+3 ;Process all DSS Units
+4 IF ECALL
SET ECD=0
Begin DoDot:1
+5 FOR
SET ECD=$ORDER(^ECJ("AP",ECL,ECD))
if 'ECD
QUIT
Begin DoDot:2
+6 DO SET
DO CATS
if 'ECOUT&UCNT
DO PAGE
End DoDot:2
if ECOUT
QUIT
End DoDot:1
GOTO END
+7 ;Process a specific DSS Unit
+8 SET UCNT=0
Begin DoDot:1
+9 IF ECC="ALL"
DO CATS
QUIT
+10 IF 'ECJLP
SET ECC=0
SET ECCN="None"
SET ECCO=999
+11 DO PROC
End DoDot:1
END ;119 Nothing to write if exporting
IF 'ECNT
IF $GET(ECPTYP)'="E"
WRITE !!!,"Nothing Found."
+1 SET ECPG=$GET(ECPG,1)
+2 QUIT
SET ;set var
+1 SET ECDN=$SELECT($PIECE($GET(^ECD(+ECD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
SET UCNT=0
+2 SET ECDN=ECDN_$SELECT($PIECE($GET(^ECD(+ECD,0)),"^",6):" **Inactive**",1:"")
+3 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
+2 WRITE !!,?24,"EVENT CODE SCREENS WITH"
+3 WRITE $SELECT(ECCPT="I":" INACTIVE",ECCPT="A":" ACTIVE",1:"")_" CPT CODES"
+4 WRITE ?70,"Page: ",ECPG,!?25,"Run Date: ",ECRDT,!?25,"LOCATION: "_ECLN
+5 WRITE !?25,"DSS UNIT: "_ECDN,!
SET ECPG=ECPG+1
+6 FOR I=1:1:80
WRITE "-"
+7 QUIT
CATS ;
+1 SET ECC=""
SET ECCO=0
+2 ;131 Moved calls to dot structure
FOR
SET ECC=$ORDER(^ECJ("AP",ECL,ECD,ECC))
if ECC=""
QUIT
Begin DoDot:1
+3 ;131 Don't include categories if unit is set to "no categories"
IF ECC
IF '$PIECE(^ECD(ECD,0),U,11)
QUIT
+4 ;131 Moved from for loop
DO SETC
DO PROC
End DoDot:1
if ECOUT
QUIT
+5 SET ECMORE=0
+6 QUIT
PROC ;
+1 SET ECP=""
+2 FOR
SET ECP=$ORDER(^ECJ("AP",ECL,ECD,ECC,ECP))
if ECP=""
QUIT
DO SETP
if ECOUT
QUIT
+3 SET ECMORE=0
+4 QUIT
SETP ;set procs
+1 SET ECPSY=+$ORDER(^ECJ("AP",ECL,ECD,ECC,ECP,""))
SET ECPI=""
+2 SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
SET ECFILE=$PIECE(ECP,";",2)
+3 ;Get clinic IEN
SET ECACIEN=+$PIECE($GET(^ECJ(ECPSY,"PRO")),U,4)
+4 ;139 Get associated clinic
SET ECAC=$$GET1^DIQ(44,ECACIEN,.01)
+5 ;145
SET NODE=$GET(^ECX(728.44,+ECACIEN,0))
+6 ;145 Stop Code
SET ECSC=$PIECE(NODE,U,2)
+7 ;145 Credit Stop Code
SET ECCSC=$PIECE(NODE,U,3)
+8 ;145 Char 4 code
SET ECCHAR=$$GET1^DIQ(728.441,$PIECE(NODE,U,8),.01)
+9 ;139,145 Get MCA Labor Code for associated clinic
SET ECMCA=$$GET1^DIQ(728.442,$PIECE(NODE,U,14),.01)
+10 SET ECFILE=$SELECT($EXTRACT(ECFILE)="I":81,$EXTRACT(ECFILE)="E":725,1:"")
+11 IF ECFILE=""
QUIT
+12 SET (ECPN,ECPT,NATN)=""
SET ECPI=0
+13 IF ECFILE=81
SET ECPI=$$CPT^ICPTCOD(+ECP)
IF +ECPI>0
Begin DoDot:1
+14 SET ECPN=$PIECE(ECPI,"^",3)
SET ECPT=$PIECE(ECPI,"^",2)
SET ECINDT=$PIECE(ECPI,"^",7)
End DoDot:1
+15 IF ECFILE=725
Begin DoDot:1
+16 SET ECP0=$GET(^EC(725,+ECP,0))
SET ECPT=""
SET ECPN=$PIECE(ECP0,"^")
+17 SET NATN=$PIECE(ECP0,"^",2)
+18 IF $PIECE(ECP0,"^",5)'=""
SET ECPI=$$CPT^ICPTCOD($PIECE(ECP0,"^",5))
IF +ECPI>0
Begin DoDot:2
+19 SET ECPT=$PIECE(ECPI,"^",2)
SET ECINDT=$PIECE(ECPI,"^",7)
End DoDot:2
End DoDot:1
+20 IF +ECPI<1
QUIT
+21 IF ECCPT="A"
IF 'ECINDT
QUIT
+22 IF ECCPT="I"
IF ECINDT
QUIT
+23 ;119 Nothing to write if exporting
IF $GET(ECPTYP)="E"
DO EXPORT
QUIT
+24 IF ECD'=ECDO
DO HEADER
SET ECDO=ECD
+25 IF ECC'=ECCO
Begin DoDot:1
+26 WRITE !!,"Category: "_ECCN
if $Y+4>IOSL
DO CONTD
End DoDot:1
SET ECCO=ECC
IF ECOUT
QUIT
+27 ;139
SET ECNT=ECNT+1
SET UCNT=UCNT+1
+28 WRITE !,"Procedure: ",$EXTRACT(ECPN,1,30)," (",$SELECT(ECFILE=81:"CPT",1:"EC"),")",?48,"Nat'l #: ",NATN,?64,"CPT: ",ECPT
+29 IF ECCPT="B"
IF 'ECINDT
WRITE ?70," *I*"
+30 ;139
IF $GET(ECPSYN)'=""
WRITE !," Synonym: ",ECPSYN
+31 ;139,145
IF $GET(ECAC)'=""
WRITE !," Associated Clinic: ",ECAC,!," Stop Code: ",ECSC,?19,"Credit Stop: ",ECCSC,?38,"CHAR4: ",ECCHAR,?52,"MCA Labor Code: ",ECMCA
+32 if ($Y+3)>IOSL
DO CONTD
IF ECOUT
QUIT
+33 QUIT
CONTD ;Check whether to continue or exit
+1 DO PAGE
IF ECOUT
QUIT
+2 if ECPG
DO HEADER
if $DATA(ECCN)
DO MORE
+3 QUIT
+4 ;
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 !!,"Category: "_ECCN
+1 QUIT
+2 ;
EXPORT ;Section added in patch 119
+1 SET CNT=CNT+1
+2 ;139,145
SET ^TMP($JOB,"ECRPT",CNT)=ECLN_U_ECDN_U_ECCN_U_ECPT_$SELECT('ECINDT:" **Inactive**",1:"")_U_NATN_U_ECPN_" ("_$SELECT(ECFILE=81:"CPT",1:"EC")_")"_U_ECPSYN_U_ECAC_U_ECSC_U_ECCSC_U_ECCHAR_U_ECMCA
+3 QUIT
