Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECSCPT1

ECSCPT1.m

Go to the documentation of this file.
  1. 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
  1. EN ;entry point
  1. N UCNT,ECDO,ECCO,ECNT,ECINDT,ECP0
  1. S (ECMORE,ECNT,ECDO,ECCO)=0,ECPG=$G(ECPG,1),ECCPT=$G(ECCPT,"B")
  1. ;Process all DSS Units
  1. I ECALL S ECD=0 D G END
  1. .F S ECD=$O(^ECJ("AP",ECL,ECD)) Q:'ECD D Q:ECOUT
  1. ..D SET,CATS,PAGE:'ECOUT&UCNT
  1. ;Process a specific DSS Unit
  1. S UCNT=0 D
  1. .I ECC="ALL" D CATS Q
  1. .I 'ECJLP S ECC=0,ECCN="None",ECCO=999
  1. .D PROC
  1. END I 'ECNT,$G(ECPTYP)'="E" W !!!,"Nothing Found." ;119 Nothing to write if exporting
  1. S ECPG=$G(ECPG,1)
  1. Q
  1. SET ;set var
  1. S ECDN=$S($P($G(^ECD(+ECD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),UCNT=0
  1. S ECDN=ECDN_$S($P($G(^ECD(+ECD,0)),"^",6):" **Inactive**",1:"")
  1. Q
  1. SETC ;set cats
  1. I ECC=0 S ECCN="None" Q
  1. S ECCN=$S($P($G(^EC(726,+ECC,0)),"^")]"":$P(^(0),"^"),1:"ZZ #"_ECC_" MISSING DATA")
  1. S ECMORE=1
  1. Q
  1. W:$E(IOST,1,2)="C-"!(ECPG>1) @IOF
  1. W !!,?24,"EVENT CODE SCREENS WITH"
  1. W $S(ECCPT="I":" INACTIVE",ECCPT="A":" ACTIVE",1:"")_" CPT CODES"
  1. W ?70,"Page: ",ECPG,!?25,"Run Date: ",ECRDT,!?25,"LOCATION: "_ECLN
  1. W !?25,"DSS UNIT: "_ECDN,! S ECPG=ECPG+1
  1. F I=1:1:80 W "-"
  1. Q
  1. CATS ;
  1. S ECC="",ECCO=0
  1. F S ECC=$O(^ECJ("AP",ECL,ECD,ECC)) Q:ECC="" D Q:ECOUT ;131 Moved calls to dot structure
  1. .I ECC,'$P(^ECD(ECD,0),U,11) Q ;131 Don't include categories if unit is set to "no categories"
  1. .D SETC,PROC ;131 Moved from for loop
  1. S ECMORE=0
  1. Q
  1. PROC ;
  1. S ECP=""
  1. F S ECP=$O(^ECJ("AP",ECL,ECD,ECC,ECP)) Q:ECP="" D SETP Q:ECOUT
  1. S ECMORE=0
  1. Q
  1. SETP ;set procs
  1. S ECPSY=+$O(^ECJ("AP",ECL,ECD,ECC,ECP,"")),ECPI=""
  1. S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2),ECFILE=$P(ECP,";",2)
  1. S ECACIEN=+$P($G(^ECJ(ECPSY,"PRO")),U,4) ;Get clinic IEN
  1. S ECAC=$$GET1^DIQ(44,ECACIEN,.01) ;139 Get associated clinic
  1. S NODE=$G(^ECX(728.44,+ECACIEN,0)) ;145
  1. S ECSC=$P(NODE,U,2) ;145 Stop Code
  1. S ECCSC=$P(NODE,U,3) ;145 Credit Stop Code
  1. S ECCHAR=$$GET1^DIQ(728.441,$P(NODE,U,8),.01) ;145 Char 4 code
  1. S ECMCA=$$GET1^DIQ(728.442,$P(NODE,U,14),.01) ;139,145 Get MCA Labor Code for associated clinic
  1. S ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"")
  1. I ECFILE="" Q
  1. S (ECPN,ECPT,NATN)="",ECPI=0
  1. I ECFILE=81 S ECPI=$$CPT^ICPTCOD(+ECP) I +ECPI>0 D
  1. .S ECPN=$P(ECPI,"^",3),ECPT=$P(ECPI,"^",2),ECINDT=$P(ECPI,"^",7)
  1. I ECFILE=725 D
  1. .S ECP0=$G(^EC(725,+ECP,0)),ECPT="",ECPN=$P(ECP0,"^")
  1. .S NATN=$P(ECP0,"^",2)
  1. .I $P(ECP0,"^",5)'="" S ECPI=$$CPT^ICPTCOD($P(ECP0,"^",5)) I +ECPI>0 D
  1. ..S ECPT=$P(ECPI,"^",2),ECINDT=$P(ECPI,"^",7)
  1. I +ECPI<1 Q
  1. I ECCPT="A",'ECINDT Q
  1. I ECCPT="I",ECINDT Q
  1. I $G(ECPTYP)="E" D EXPORT Q ;119 Nothing to write if exporting
  1. I ECD'=ECDO D HEADER S ECDO=ECD
  1. I ECC'=ECCO D S ECCO=ECC I ECOUT Q
  1. .W !!,"Category: "_ECCN D:$Y+4>IOSL CONTD
  1. S ECNT=ECNT+1,UCNT=UCNT+1 ;139
  1. W !,"Procedure: ",$E(ECPN,1,30)," (",$S(ECFILE=81:"CPT",1:"EC"),")",?48,"Nat'l #: ",NATN,?64,"CPT: ",ECPT
  1. I ECCPT="B",'ECINDT W ?70," *I*"
  1. I $G(ECPSYN)'="" W !," Synonym: ",ECPSYN ;139
  1. I $G(ECAC)'="" W !," Associated Clinic: ",ECAC,!," Stop Code: ",ECSC,?19,"Credit Stop: ",ECCSC,?38,"CHAR4: ",ECCHAR,?52,"MCA Labor Code: ",ECMCA ;139,145
  1. D:($Y+3)>IOSL CONTD I ECOUT Q
  1. Q
  1. CONTD ;Check whether to continue or exit
  1. D PAGE I ECOUT Q
  1. D HEADER:ECPG,MORE:$D(ECCN)
  1. Q
  1. ;
  1. PAGE ;
  1. N SS,JJ
  1. I $D(ECPG),$E(IOST,1,2)="C-" D
  1. . S SS=22-$Y F JJ=1:1:SS W !
  1. . S DIR(0)="E" W ! D ^DIR K DIR I 'Y S ECOUT=1
  1. Q
  1. MORE I ECMORE W !!,"Category: "_ECCN
  1. Q
  1. ;
  1. EXPORT ;Section added in patch 119
  1. S CNT=CNT+1
  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
  1. Q