- 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 Feb 18, 2025@23:25:13 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