source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMFECS.m@ 1608

Last change on this file since 1608 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1ECMFECS ;ALB/JAM-Event Capture Management - Event Code Screen Filer;27 Nov 00
2 ;;2.0; EVENT CAPTURE ;**25,33,47,55,65**;8 May 96
3 ;
4FILE ;Used by the RPC broker to file EC Code Screens in file #720.3
5 ; Variables passed in
6 ; ECIEN - IEN of #720.3, if editing
7 ; ECL - Location
8 ; ECD - DSS Unit
9 ; ECC - Category
10 ; ECP - Procedure
11 ; ECST - Event code screen status
12 ; ECSYN - Synonym
13 ; ECVOL - Volume
14 ; ECAC - Associated Clinic
15 ; ECREAS - Reason indicator
16 ; ECRES0..n - array of reasons
17 ;
18 ; Variable return
19 ; ^TMP($J,"ECMSG",n)=Success or failure to file in #720.3^Message
20 ;
21 N ECCH,ECERR,ECX,ECY,ECFLG,ECR,ECI,X,Y,DIK,DIE
22 S ECERR=0 D CHKDT I ECERR Q
23 D VALDATA I ECERR Q
24 I ECIEN'="" S ECFLG=0,ECX=$G(^ECJ(ECIEN,0)),ECY=$P(ECX,U) D I ECERR Q
25 .I ECX="" D Q
26 ..S ECERR=1,^TMP($J,"ECMSG",1)="0^Event Code Screen Not on File" Q
27 .S ECL=$P(ECY,"-"),ECD=$P(ECY,"-",2),ECC=$P(ECY,"-",3),ECP=$P(ECY,"-",4)
28 .I ECST="A",$P(ECX,U,2)'="" S DA=ECIEN,DIE="^ECJ(",DR="1///@" D ^DIE Q
29 .I ECST="I",$P(ECX,U,2)="" S $P(^ECJ(ECIEN,0),U,2)=DT
30 S ECC=$G(ECC,0),ECCH=ECL_"-"_ECD_"-"_ECC_"-"_ECP
31 I '$P($G(^ECD(ECD,0)),U,11),ECC D Q
32 .S ECERR=1,^TMP($J,"ECMSG",1)="0^DSS Unit/Category inconsistency" Q
33 I ECIEN="" D I ECERR Q
34 .I $D(^ECJ("B",ECCH)) D Q
35 ..S ECERR=1,^TMP($J,"ECMSG",1)="0^EC Screen Exist" Q
36 .D NEWIEN
37 S DA=ECIEN,DIK="^ECJ(",ECREAS=$S(ECREAS="Y":1,1:0) D IX^DIK
38 S ^ECJ("AP",ECL,ECD,ECC,ECP,ECIEN)="",^ECJ("APP",ECL,ECD,ECP,ECIEN)=""
39 S $P(^ECJ(ECIEN,"PRO"),U)=ECP,ECAC=$S($G(ECAC)'="":ECAC,1:"@")
40 S DR="53////"_$S($G(ECSYN)'="":ECSYN,1:"@")_";54////"_$G(ECVOL,1)
41 S DR=DR_";55////"_$G(ECAC)_";56////"_ECREAS,DIE="^ECJ(",DA=ECIEN
42 D ^DIE K DA,DR,DIE
43 I $D(DTOUT) D RECDEL S ^TMP($J,"ECMSG",1)="0^Record not Filed" Q
44 I ECREAS D
45 .K DIC,DA,DR,ECX S DIC="^ECL(",DIC(0)="L",DLAYGO=720.5,ECR=0
46 .F ECI=0:1 S ECX="ECRES"_ECI Q:'$D(@ECX) S ECR=(@ECX) D
47 ..Q:ECR="" I '$D(^ECR(ECR,0)) Q
48 ..I '$D(^ECL("AD",ECIEN,ECR)) S X=ECR,DIC("DR")=".02////"_ECIEN
49 ..K DD,DO,DLAYGO D FILE^DICN
50 S ^TMP($J,"ECMSG",1)="1^Record Filed"_U_ECIEN
51 Q
52 ;
53VALDATA ;validate data
54 N ECRRX,ECRES
55 S DIC="^DIC(4,",DIC(0)="NX",X=ECL D ^DIC I Y=-1 D Q
56 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Location"
57 S DIC="^ECD(",DIC(0)="NX",X=ECD D ^DIC I Y=-1 D Q
58 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid DSS Unit"
59 I ECC S DIC="^EC(726,",DIC(0)="NX",X=ECC D ^DIC I Y=-1 D Q
60 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Category"
61 I ECP'="" D I ECERR Q
62 .; ATG-1003-32110 : by VMP
63 .I ECP["ICPT" S ECRRX=$$CPT^ICPTCOD(+ECP) I +ECRRX>0 Q:$G(ECIEN) I $P(ECRRX,U,7) Q
64 .I ECP["EC",$D(^EC(725,+ECP,0)) Q
65 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Procedure"
66 I $G(ECAC)'="" D I ECERR Q
67 .D CHK^DIE(720.3,55,"E","`"_ECAC,.ECRRX) I ECRRX'=ECAC D Q
68 ..S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Associated Clinic"
69 .S ECRES=$$CLNCK^SDUTL2(ECAC,0) I 'ECRES D S ECERR=1
70 ..S ^TMP($J,"ECMSG",1)=ECRES_" Clinic MUST be corrected before filing."
71 I $G(ECSYN)'="" D CHK^DIE(720.3,53,"E",ECSYN,.ECRRX) I ECRRX'=ECSYN D Q
72 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Synonym"
73 I "^N^Y^"'[U_ECREAS_U D Q
74 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Reason Response"
75 Q
76RECDEL ; Delete record
77 I ECFLG S DA=ECIEN,DIK="^ECJ(" D ^DIK K DA,DIK
78 Q
79 ;
80NEWIEN ;Create new IEN in file #720.3
81 N DIC,DA,DD,DO
82 L +^ECJ(0)
83 S X=ECCH,DIC="^ECJ(",DIC(0)="L",DLAYGO=720.3 D FILE^DICN
84 L -^ECJ(0)
85 S ECIEN=+Y,$P(^ECJ(ECIEN,0),U,3)=DT,$P(^ECJ(ECIEN,"PRO"),U)=ECP
86 I ECST="I" S $P(^ECJ(ECIEN,0),U,2)=DT
87 Q
88CHKDT ;Required Data Check
89 N I,C
90 S C=1
91 F I="ECL","ECD","ECC","ECP","ECREAS" D
92 .I $G(@I)="" S ^TMP($J,"ECMSG",C)="0^Key data missing "_I,C=C+1,ECERR=1
93 Q
94REASON ;Used by the RPC broker to file EC Reasons in file #720.4
95 ; Variables passed in
96 ; ECIEN - IEN of #720.4, if editing
97 ; ECRES - Reason
98 ; ECST - Reason status
99 ;
100 ; Variable return
101 ; ^TMP($J,"ECMSG",n)=Success or failure to file in #720.4^Message
102 ;
103 N ECOST,ECERR,ECFLG,X,Y,DIC,DIE
104 S ECERR=0 I $G(ECRES)="" D I ECERR Q
105 .S ^TMP($J,"ECMSG",1)="0^Key data missing - Reason",ECERR=1
106 D CHK^DIE(720.4,.01,,ECRES,.ECRRX) I ECRRX="^" D Q
107 .S ^TMP($J,"ECMSG",1)="0^Invalid Reason",ECERR=1
108 S ECST=$G(ECST,"A")
109 I "^I^A^"'[U_ECST_U S ^TMP($J,"ECMSG",1)="0^Invalid Reason Status" Q
110 S ECST=$S(ECST="I":0,1:1),ECIEN=$G(ECIEN),ECFLG=1
111 I ECIEN'="" S ECFLG=0 I $G(^ECR(ECIEN,0))="" D I ECERR K ECST Q
112 .S ECERR=1,^TMP($J,"ECMSG",1)="0^Reason Not on File" Q
113 I ECIEN="" D I ECERR K ECST Q
114 .I $D(^ECR("B",ECRES)) S ECERR=1,^TMP($J,"ECMSG",1)="0^Reason Exist" Q
115 .K DIE,DR,DA
116 .L +^ECR(0)
117 .S X=ECRES,DIC="^ECR(",DIC(0)="L",DLAYGO=720.4 D FILE^DICN
118 .L -^ECR(0)
119 .S ECIEN=+Y
120 S ECOST=$P($G(^ECR(ECIEN,0)),U,2)
121 I ECST'=ECOST D
122 .S DIE=DIC,DA=ECIEN,DR=".02////"_ECST D ^DIE
123 S ^TMP($J,"ECMSG",1)="1^Reason Filed"_U_ECIEN K ECST
124 Q
Note: See TracBrowser for help on using the repository browser.