ECMFECS ;ALB/JAM - Event Capture Management - Event Code Screen Filer ;11/6/12 09:56
;;2.0;EVENT CAPTURE;**25,33,47,55,65,95,100,119**;8 May 96;Build 12
;
I $G(ECL0)'="" D MULTLOC Q ;multiple location filing
;
FILE ;Used by the RPC broker to file EC Code Screens in file #720.3
; Variables passed in
; ECIEN - IEN of #720.3, if editing
; ECL - Location
; ECD - DSS Unit
; ECC - Category
; ECP - Procedure
; ECST - Event code screen status
; ECSYN - Synonym
; ECVOL - Volume
; ECAC - Associated Clinic
; ECREAS - Reason indicator
; ECRES0..n - array of reasons
;
; Variable return
; ^TMP($J,"ECMSG",n)=Success or failure to file in #720.3^Message
;
N ECCH,ECERR,ECX,ECY,ECFLG,ECR,ECI,X,Y,DIK,DIE
N ECLOC ;protect from XREF reuse & kills
N ECRES ;prevent ECREAS overwrite
S ECERR=0 D CHKDT I ECERR Q
D VALDATA I ECERR Q
I ECIEN'="" S ECFLG=0,ECX=$G(^ECJ(ECIEN,0)),ECY=$P(ECX,U) D I ECERR Q
.I ECX="" D Q
..S ECERR=1,^TMP($J,"ECMSG",1)="0^Event Code Screen Not on File" Q
.S ECL=$P(ECY,"-"),ECD=$P(ECY,"-",2),ECC=$P(ECY,"-",3),ECP=$P(ECY,"-",4)
.I ECST="A",$P(ECX,U,2)'="" S DA=ECIEN,DIE="^ECJ(",DR="1///@" D ^DIE Q
.I ECST="I",$P(ECX,U,2)="" S $P(^ECJ(ECIEN,0),U,2)=DT
S ECC=$G(ECC,0),ECCH=ECL_"-"_ECD_"-"_ECC_"-"_ECP
I '$P($G(^ECD(ECD,0)),U,11),ECC D Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^DSS Unit/Category inconsistency" Q
I ECIEN="" D I ECERR Q
.I $D(^ECJ("B",ECCH)) D Q
..S ECERR=1,^TMP($J,"ECMSG",1)="0^EC Screen Exist" Q
.D NEWIEN
S DA=ECIEN,DIK="^ECJ(",ECRES=$S(ECREAS="Y":1,1:0) D IX^DIK
S ^ECJ("AP",ECL,ECD,ECC,ECP,ECIEN)="",^ECJ("APP",ECL,ECD,ECP,ECIEN)=""
S $P(^ECJ(ECIEN,"PRO"),U)=ECP
S DR="53////"_$S($G(ECSYN)'="":ECSYN,1:"@")_";54////"_$G(ECVOL,1)
S DR=DR_";55////"_$S($G(ECAC)'="":ECAC,1:"@")_";56////"_ECRES,DIE="^ECJ(",DA=ECIEN
D ^DIE K DA,DR,DIE
I $D(DTOUT) D RECDEL S ^TMP($J,"ECMSG",1)="0^Record not Filed" Q
I ECRES D
.N ECLARR,ECLIEN
.K DIC,DA,DR,ECX S DIC="^ECL(",DIC(0)="L",DLAYGO=720.5,ECR=0
.F ECI=0:1 S ECX="ECRES"_ECI Q:'$D(@ECX) S ECR=(@ECX) D
..Q:ECR="" I '$D(^ECR(ECR,0)) Q
..S ECLARR(ECR)="" ; control of valid passed in Procedure Reason Codes
..I '$D(^ECL("AD",ECIEN,ECR)) S X=ECR,DIC("DR")=".02////"_ECIEN
..K DD,DO,DLAYGO D FILE^DICN
.;kill nodes no Procedure Reason Code passed in but "AD" Xref exists
.K DIK S DIK="^ECL(",DA=""
.S ECR=0 F S ECR=$O(^ECL("AD",ECIEN,ECR)) Q:ECR="" D
..I $D(ECLARR(ECR)) Q ;procedure reason code passed in - don't remove
..S ECLIEN=0 F S ECLIEN=$O(^ECL("AD",ECIEN,ECR,ECLIEN)) Q:ECLIEN="" S DA=ECLIEN D ^DIK
S ^TMP($J,"ECMSG",1)="1^Record Filed"_U_ECIEN
K DIC,DA,DR,ECX,DIK
Q
;
VALDATA ;validate data
N ECRRX,ECRES
S DIC="^DIC(4,",DIC(0)="NX",X=ECL D ^DIC I Y=-1 D Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Location"
S DIC="^ECD(",DIC(0)="NX",X=ECD D ^DIC I Y=-1 D Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid DSS Unit"
I ECC S DIC="^EC(726,",DIC(0)="NX",X=ECC D ^DIC I Y=-1 D Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Category"
I ECP'="" D I ECERR Q
.; ATG-1003-32110 : by VMP
.I ECP["ICPT" S ECRRX=$$CPT^ICPTCOD(+ECP) I +ECRRX>0 Q:$G(ECIEN) I $P(ECRRX,U,7) Q
.I ECP["EC",$D(^EC(725,+ECP,0)) Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Procedure"
I $G(ECAC)'="" D I ECERR Q
.D CHK^DIE(720.3,55,"E","`"_ECAC,.ECRRX) I ECRRX'=ECAC D Q
..S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Associated Clinic"
.S ECRES=$$CLNCK^SDUTL2(ECAC,0) I 'ECRES D S ECERR=1
..S ^TMP($J,"ECMSG",1)=ECRES_" Clinic MUST be corrected before filing."
I $G(ECSYN)'="" D CHK^DIE(720.3,53,"E",ECSYN,.ECRRX) I ECRRX'=ECSYN D Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Synonym"
I "^N^Y^"'[U_ECREAS_U D Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Reason Response"
Q
RECDEL ; Delete record
I ECFLG S DA=ECIEN,DIK="^ECJ(" D ^DIK K DA,DIK
Q
;
NEWIEN ;Create new IEN in file #720.3
N DIC,DA,DD,DO
L +^ECJ(0):10 I '$T S ECERR=1,^TMP($J,"ECMSG",1)="0^Another user is editing this file." Q
S X=ECCH,DIC="^ECJ(",DIC(0)="L",DLAYGO=720.3 D FILE^DICN
L -^ECJ(0)
S ECIEN=+Y,$P(^ECJ(ECIEN,0),U,3)=DT,$P(^ECJ(ECIEN,"PRO"),U)=ECP
I ECST="I" S $P(^ECJ(ECIEN,0),U,2)=DT
Q
CHKDT ;Required Data Check
N I,C
S C=1
F I="ECL","ECD","ECC","ECP","ECREAS" D
.I $G(@I)="" S ^TMP($J,"ECMSG",C)="0^Key data missing "_I,C=C+1,ECERR=1
Q
REASON ;Used by the RPC broker to file EC Reasons in file #720.4
; Variables passed in
; ECIEN - IEN of #720.4, if editing
; ECRES - Reason
; ECST - Reason status
;
; Variable return
; ^TMP($J,"ECMSG",n)=Success or failure to file in #720.4^Message
;
N ECOST,ECERR,ECFLG,X,Y,DIC,DIE
S ECERR=0 I $G(ECRES)="" D I ECERR Q
.S ^TMP($J,"ECMSG",1)="0^Key data missing - Reason",ECERR=1
D CHK^DIE(720.4,.01,,ECRES,.ECRRX) I ECRRX="^" D Q
.S ^TMP($J,"ECMSG",1)="0^Invalid Reason",ECERR=1
S ECST=$G(ECST,"A")
I "^I^A^"'[U_ECST_U S ^TMP($J,"ECMSG",1)="0^Invalid Reason Status" Q
S ECST=$S(ECST="I":0,1:1),ECIEN=$G(ECIEN),ECFLG=1
I ECIEN'="" S ECFLG=0 I $G(^ECR(ECIEN,0))="" D I ECERR K ECST Q
.S ECERR=1,^TMP($J,"ECMSG",1)="0^Reason Not on File" Q
I ECIEN="" D I ECERR K ECST Q
.I $D(^ECR("B",ECRES)) S ECERR=1,^TMP($J,"ECMSG",1)="0^Reason Exist" Q
.K DIE,DR,DA
.L +^ECR(0):10 I '$T S ECERR=1,^TMP($J,"ECMSG",1)="0^Another user is editing this file." Q
.S X=ECRES,DIC="^ECR(",DIC(0)="L",DLAYGO=720.4 D FILE^DICN
.L -^ECR(0)
.S ECIEN=+Y
S ECOST=$P($G(^ECR(ECIEN,0)),U,2)
I ECST'=ECOST D
.S DIE="^ECR(",DA=ECIEN,DR=".02////"_ECST D ^DIE ;119
S ^TMP($J,"ECMSG",1)="1^Reason Filed"_U_ECIEN K ECST
Q
;
MULTLOC ;Entry point for multiple locations
; Input:
; ECL0..n - locations IEN
; ECIEN - IEN for edits; "" for new records
; See FILE tag for other variables passed in
;
; Output:
; ^TMP($J,"ECMSG",n)=Success or failure
;
N ECERR ;error flag
N ECI ;generic index
N ECL ;location IEN
N ECLN ;location name
N ECLOC ;array of locations
N ECX ;variable name (ex. ECL1)
;
;short circuit when IEN passed w/multiple locations
I (+$G(ECIEN)>0)&(ECL0="ALL"!($D(ECL1))) D Q
. S ^TMP($J,"ECMSG",1)=0_U_"Multiple location edits not allowed"
;
I ECL0="ALL" D
. D LOCARRY^ECRUTL ;returns all sites in ECLOC(n)=IEN^name format
E D
. F ECI=0:1 S ECX="ECL"_ECI Q:'$D(@ECX) D
. . S ECLN=$$GET1^DIQ(4,@ECX_",",.01,"")
. . S ECLOC(ECI+1)=@ECX_U_ECLN
;
S ECI=0
F S ECI=$O(ECLOC(ECI)) Q:'ECI D
. I ECL0="ALL"!($D(ECL1)) N ECIEN S ECIEN="" ;reset IEN for multiple
. S ECL=+ECLOC(ECI)
. D FILE^ECMFECS
. I $P(^TMP($J,"ECMSG",1),U)=0 S ECERR(ECI)=ECLOC(ECI)_U_$P(^TMP($J,"ECMSG",1),U,2)
;
;process results
I '$D(ECERR) S ^TMP($J,"ECMSG",1)=1_U_"Records filed for all locations"
E D PROCERR(.ECERR)
Q
;
PROCERR(ECERR) ;process multiple location errors
; Input:
; ECERR - array of location errors
;
; Output:
; ^TMP($J,"ECMSG" - RPC results global array
; Format: ^TMP($J,"ECMSG",1)="0^One or more locations did not file"
; ^TMP($J,"ECMSG",n)=Location_IEN^Location_name^Error_text
;
Q:'$D(ECERR)
;
N ECCNT,ECI
S ECCNT=1
S ^TMP($J,"ECMSG",ECCNT)=0_U_"One or more locations did not file"
S ECI=0
F S ECI=$O(ECERR(ECI)) Q:'ECI S ECCNT=ECCNT+1 D
. S ^TMP($J,"ECMSG",ECCNT)=$P(ECERR(ECI),U)_U_$P(ECERR(ECI),U,2)_U_$P(ECERR(ECI),U,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECMFECS 7567 printed Dec 13, 2024@01:57:39 Page 2
ECMFECS ;ALB/JAM - Event Capture Management - Event Code Screen Filer ;11/6/12 09:56
+1 ;;2.0;EVENT CAPTURE;**25,33,47,55,65,95,100,119**;8 May 96;Build 12
+2 ;
+3 ;multiple location filing
IF $GET(ECL0)'=""
DO MULTLOC
QUIT
+4 ;
FILE ;Used by the RPC broker to file EC Code Screens in file #720.3
+1 ; Variables passed in
+2 ; ECIEN - IEN of #720.3, if editing
+3 ; ECL - Location
+4 ; ECD - DSS Unit
+5 ; ECC - Category
+6 ; ECP - Procedure
+7 ; ECST - Event code screen status
+8 ; ECSYN - Synonym
+9 ; ECVOL - Volume
+10 ; ECAC - Associated Clinic
+11 ; ECREAS - Reason indicator
+12 ; ECRES0..n - array of reasons
+13 ;
+14 ; Variable return
+15 ; ^TMP($J,"ECMSG",n)=Success or failure to file in #720.3^Message
+16 ;
+17 NEW ECCH,ECERR,ECX,ECY,ECFLG,ECR,ECI,X,Y,DIK,DIE
+18 ;protect from XREF reuse & kills
NEW ECLOC
+19 ;prevent ECREAS overwrite
NEW ECRES
+20 SET ECERR=0
DO CHKDT
IF ECERR
QUIT
+21 DO VALDATA
IF ECERR
QUIT
+22 IF ECIEN'=""
SET ECFLG=0
SET ECX=$GET(^ECJ(ECIEN,0))
SET ECY=$PIECE(ECX,U)
Begin DoDot:1
+23 IF ECX=""
Begin DoDot:2
+24 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Event Code Screen Not on File"
QUIT
End DoDot:2
QUIT
+25 SET ECL=$PIECE(ECY,"-")
SET ECD=$PIECE(ECY,"-",2)
SET ECC=$PIECE(ECY,"-",3)
SET ECP=$PIECE(ECY,"-",4)
+26 IF ECST="A"
IF $PIECE(ECX,U,2)'=""
SET DA=ECIEN
SET DIE="^ECJ("
SET DR="1///@"
DO ^DIE
QUIT
+27 IF ECST="I"
IF $PIECE(ECX,U,2)=""
SET $PIECE(^ECJ(ECIEN,0),U,2)=DT
End DoDot:1
IF ECERR
QUIT
+28 SET ECC=$GET(ECC,0)
SET ECCH=ECL_"-"_ECD_"-"_ECC_"-"_ECP
+29 IF '$PIECE($GET(^ECD(ECD,0)),U,11)
IF ECC
Begin DoDot:1
+30 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^DSS Unit/Category inconsistency"
QUIT
End DoDot:1
QUIT
+31 IF ECIEN=""
Begin DoDot:1
+32 IF $DATA(^ECJ("B",ECCH))
Begin DoDot:2
+33 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^EC Screen Exist"
QUIT
End DoDot:2
QUIT
+34 DO NEWIEN
End DoDot:1
IF ECERR
QUIT
+35 SET DA=ECIEN
SET DIK="^ECJ("
SET ECRES=$SELECT(ECREAS="Y":1,1:0)
DO IX^DIK
+36 SET ^ECJ("AP",ECL,ECD,ECC,ECP,ECIEN)=""
SET ^ECJ("APP",ECL,ECD,ECP,ECIEN)=""
+37 SET $PIECE(^ECJ(ECIEN,"PRO"),U)=ECP
+38 SET DR="53////"_$SELECT($GET(ECSYN)'="":ECSYN,1:"@")_";54////"_$GET(ECVOL,1)
+39 SET DR=DR_";55////"_$SELECT($GET(ECAC)'="":ECAC,1:"@")_";56////"_ECRES
SET DIE="^ECJ("
SET DA=ECIEN
+40 DO ^DIE
KILL DA,DR,DIE
+41 IF $DATA(DTOUT)
DO RECDEL
SET ^TMP($JOB,"ECMSG",1)="0^Record not Filed"
QUIT
+42 IF ECRES
Begin DoDot:1
+43 NEW ECLARR,ECLIEN
+44 KILL DIC,DA,DR,ECX
SET DIC="^ECL("
SET DIC(0)="L"
SET DLAYGO=720.5
SET ECR=0
+45 FOR ECI=0:1
SET ECX="ECRES"_ECI
if '$DATA(@ECX)
QUIT
SET ECR=(@ECX)
Begin DoDot:2
+46 if ECR=""
QUIT
IF '$DATA(^ECR(ECR,0))
QUIT
+47 ; control of valid passed in Procedure Reason Codes
SET ECLARR(ECR)=""
+48 IF '$DATA(^ECL("AD",ECIEN,ECR))
SET X=ECR
SET DIC("DR")=".02////"_ECIEN
+49 KILL DD,DO,DLAYGO
DO FILE^DICN
End DoDot:2
+50 ;kill nodes no Procedure Reason Code passed in but "AD" Xref exists
+51 KILL DIK
SET DIK="^ECL("
SET DA=""
+52 SET ECR=0
FOR
SET ECR=$ORDER(^ECL("AD",ECIEN,ECR))
if ECR=""
QUIT
Begin DoDot:2
+53 ;procedure reason code passed in - don't remove
IF $DATA(ECLARR(ECR))
QUIT
+54 SET ECLIEN=0
FOR
SET ECLIEN=$ORDER(^ECL("AD",ECIEN,ECR,ECLIEN))
if ECLIEN=""
QUIT
SET DA=ECLIEN
DO ^DIK
End DoDot:2
End DoDot:1
+55 SET ^TMP($JOB,"ECMSG",1)="1^Record Filed"_U_ECIEN
+56 KILL DIC,DA,DR,ECX,DIK
+57 QUIT
+58 ;
VALDATA ;validate data
+1 NEW ECRRX,ECRES
+2 SET DIC="^DIC(4,"
SET DIC(0)="NX"
SET X=ECL
DO ^DIC
IF Y=-1
Begin DoDot:1
+3 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Location"
End DoDot:1
QUIT
+4 SET DIC="^ECD("
SET DIC(0)="NX"
SET X=ECD
DO ^DIC
IF Y=-1
Begin DoDot:1
+5 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid DSS Unit"
End DoDot:1
QUIT
+6 IF ECC
SET DIC="^EC(726,"
SET DIC(0)="NX"
SET X=ECC
DO ^DIC
IF Y=-1
Begin DoDot:1
+7 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Category"
End DoDot:1
QUIT
+8 IF ECP'=""
Begin DoDot:1
+9 ; ATG-1003-32110 : by VMP
+10 IF ECP["ICPT"
SET ECRRX=$$CPT^ICPTCOD(+ECP)
IF +ECRRX>0
if $GET(ECIEN)
QUIT
IF $PIECE(ECRRX,U,7)
QUIT
+11 IF ECP["EC"
IF $DATA(^EC(725,+ECP,0))
QUIT
+12 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Procedure"
End DoDot:1
IF ECERR
QUIT
+13 IF $GET(ECAC)'=""
Begin DoDot:1
+14 DO CHK^DIE(720.3,55,"E","`"_ECAC,.ECRRX)
IF ECRRX'=ECAC
Begin DoDot:2
+15 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Associated Clinic"
End DoDot:2
QUIT
+16 SET ECRES=$$CLNCK^SDUTL2(ECAC,0)
IF 'ECRES
Begin DoDot:2
+17 SET ^TMP($JOB,"ECMSG",1)=ECRES_" Clinic MUST be corrected before filing."
End DoDot:2
SET ECERR=1
End DoDot:1
IF ECERR
QUIT
+18 IF $GET(ECSYN)'=""
DO CHK^DIE(720.3,53,"E",ECSYN,.ECRRX)
IF ECRRX'=ECSYN
Begin DoDot:1
+19 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Synonym"
End DoDot:1
QUIT
+20 IF "^N^Y^"'[U_ECREAS_U
Begin DoDot:1
+21 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Reason Response"
End DoDot:1
QUIT
+22 QUIT
RECDEL ; Delete record
+1 IF ECFLG
SET DA=ECIEN
SET DIK="^ECJ("
DO ^DIK
KILL DA,DIK
+2 QUIT
+3 ;
NEWIEN ;Create new IEN in file #720.3
+1 NEW DIC,DA,DD,DO
+2 LOCK +^ECJ(0):10
IF '$TEST
SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Another user is editing this file."
QUIT
+3 SET X=ECCH
SET DIC="^ECJ("
SET DIC(0)="L"
SET DLAYGO=720.3
DO FILE^DICN
+4 LOCK -^ECJ(0)
+5 SET ECIEN=+Y
SET $PIECE(^ECJ(ECIEN,0),U,3)=DT
SET $PIECE(^ECJ(ECIEN,"PRO"),U)=ECP
+6 IF ECST="I"
SET $PIECE(^ECJ(ECIEN,0),U,2)=DT
+7 QUIT
CHKDT ;Required Data Check
+1 NEW I,C
+2 SET C=1
+3 FOR I="ECL","ECD","ECC","ECP","ECREAS"
Begin DoDot:1
+4 IF $GET(@I)=""
SET ^TMP($JOB,"ECMSG",C)="0^Key data missing "_I
SET C=C+1
SET ECERR=1
End DoDot:1
+5 QUIT
REASON ;Used by the RPC broker to file EC Reasons in file #720.4
+1 ; Variables passed in
+2 ; ECIEN - IEN of #720.4, if editing
+3 ; ECRES - Reason
+4 ; ECST - Reason status
+5 ;
+6 ; Variable return
+7 ; ^TMP($J,"ECMSG",n)=Success or failure to file in #720.4^Message
+8 ;
+9 NEW ECOST,ECERR,ECFLG,X,Y,DIC,DIE
+10 SET ECERR=0
IF $GET(ECRES)=""
Begin DoDot:1
+11 SET ^TMP($JOB,"ECMSG",1)="0^Key data missing - Reason"
SET ECERR=1
End DoDot:1
IF ECERR
QUIT
+12 DO CHK^DIE(720.4,.01,,ECRES,.ECRRX)
IF ECRRX="^"
Begin DoDot:1
+13 SET ^TMP($JOB,"ECMSG",1)="0^Invalid Reason"
SET ECERR=1
End DoDot:1
QUIT
+14 SET ECST=$GET(ECST,"A")
+15 IF "^I^A^"'[U_ECST_U
SET ^TMP($JOB,"ECMSG",1)="0^Invalid Reason Status"
QUIT
+16 SET ECST=$SELECT(ECST="I":0,1:1)
SET ECIEN=$GET(ECIEN)
SET ECFLG=1
+17 IF ECIEN'=""
SET ECFLG=0
IF $GET(^ECR(ECIEN,0))=""
Begin DoDot:1
+18 SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Reason Not on File"
QUIT
End DoDot:1
IF ECERR
KILL ECST
QUIT
+19 IF ECIEN=""
Begin DoDot:1
+20 IF $DATA(^ECR("B",ECRES))
SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Reason Exist"
QUIT
+21 KILL DIE,DR,DA
+22 LOCK +^ECR(0):10
IF '$TEST
SET ECERR=1
SET ^TMP($JOB,"ECMSG",1)="0^Another user is editing this file."
QUIT
+23 SET X=ECRES
SET DIC="^ECR("
SET DIC(0)="L"
SET DLAYGO=720.4
DO FILE^DICN
+24 LOCK -^ECR(0)
+25 SET ECIEN=+Y
End DoDot:1
IF ECERR
KILL ECST
QUIT
+26 SET ECOST=$PIECE($GET(^ECR(ECIEN,0)),U,2)
+27 IF ECST'=ECOST
Begin DoDot:1
+28 ;119
SET DIE="^ECR("
SET DA=ECIEN
SET DR=".02////"_ECST
DO ^DIE
End DoDot:1
+29 SET ^TMP($JOB,"ECMSG",1)="1^Reason Filed"_U_ECIEN
KILL ECST
+30 QUIT
+31 ;
MULTLOC ;Entry point for multiple locations
+1 ; Input:
+2 ; ECL0..n - locations IEN
+3 ; ECIEN - IEN for edits; "" for new records
+4 ; See FILE tag for other variables passed in
+5 ;
+6 ; Output:
+7 ; ^TMP($J,"ECMSG",n)=Success or failure
+8 ;
+9 ;error flag
NEW ECERR
+10 ;generic index
NEW ECI
+11 ;location IEN
NEW ECL
+12 ;location name
NEW ECLN
+13 ;array of locations
NEW ECLOC
+14 ;variable name (ex. ECL1)
NEW ECX
+15 ;
+16 ;short circuit when IEN passed w/multiple locations
+17 IF (+$GET(ECIEN)>0)&(ECL0="ALL"!($DATA(ECL1)))
Begin DoDot:1
+18 SET ^TMP($JOB,"ECMSG",1)=0_U_"Multiple location edits not allowed"
End DoDot:1
QUIT
+19 ;
+20 IF ECL0="ALL"
Begin DoDot:1
+21 ;returns all sites in ECLOC(n)=IEN^name format
DO LOCARRY^ECRUTL
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 FOR ECI=0:1
SET ECX="ECL"_ECI
if '$DATA(@ECX)
QUIT
Begin DoDot:2
+24 SET ECLN=$$GET1^DIQ(4,@ECX_",",.01,"")
+25 SET ECLOC(ECI+1)=@ECX_U_ECLN
End DoDot:2
End DoDot:1
+26 ;
+27 SET ECI=0
+28 FOR
SET ECI=$ORDER(ECLOC(ECI))
if 'ECI
QUIT
Begin DoDot:1
+29 ;reset IEN for multiple
IF ECL0="ALL"!($DATA(ECL1))
NEW ECIEN
SET ECIEN=""
+30 SET ECL=+ECLOC(ECI)
+31 DO FILE^ECMFECS
+32 IF $PIECE(^TMP($JOB,"ECMSG",1),U)=0
SET ECERR(ECI)=ECLOC(ECI)_U_$PIECE(^TMP($JOB,"ECMSG",1),U,2)
End DoDot:1
+33 ;
+34 ;process results
+35 IF '$DATA(ECERR)
SET ^TMP($JOB,"ECMSG",1)=1_U_"Records filed for all locations"
+36 IF '$TEST
DO PROCERR(.ECERR)
+37 QUIT
+38 ;
PROCERR(ECERR) ;process multiple location errors
+1 ; Input:
+2 ; ECERR - array of location errors
+3 ;
+4 ; Output:
+5 ; ^TMP($J,"ECMSG" - RPC results global array
+6 ; Format: ^TMP($J,"ECMSG",1)="0^One or more locations did not file"
+7 ; ^TMP($J,"ECMSG",n)=Location_IEN^Location_name^Error_text
+8 ;
+9 if '$DATA(ECERR)
QUIT
+10 ;
+11 NEW ECCNT,ECI
+12 SET ECCNT=1
+13 SET ^TMP($JOB,"ECMSG",ECCNT)=0_U_"One or more locations did not file"
+14 SET ECI=0
+15 FOR
SET ECI=$ORDER(ECERR(ECI))
if 'ECI
QUIT
SET ECCNT=ECCNT+1
Begin DoDot:1
+16 SET ^TMP($JOB,"ECMSG",ECCNT)=$PIECE(ECERR(ECI),U)_U_$PIECE(ECERR(ECI),U,2)_U_$PIECE(ECERR(ECI),U,3)
End DoDot:1
+17 QUIT
