source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMFECS.m@ 802

ECMFECS ;ALB/JAM-Event Capture Management - Event Code Screen Filer;27 Nov 00
 ;;2.0; EVENT CAPTURE ;**25,33,47,55,65**;8 May 96
 ;
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
 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(",ECREAS=$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,ECAC=$S($G(ECAC)'="":ECAC,1:"@")
 S DR="53////"_$S($G(ECSYN)'="":ECSYN,1:"@")_";54////"_$G(ECVOL,1)
 S DR=DR_";55////"_$G(ECAC)_";56////"_ECREAS,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 ECREAS D
 .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
 ..I '$D(^ECL("AD",ECIEN,ECR)) S X=ECR,DIC("DR")=".02////"_ECIEN
 ..K DD,DO,DLAYGO D FILE^DICN
 S ^TMP($J,"ECMSG",1)="1^Record Filed"_U_ECIEN
 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)
 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)
 .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=DIC,DA=ECIEN,DR=".02////"_ECST D ^DIE
 S ^TMP($J,"ECMSG",1)="1^Reason Filed"_U_ECIEN K ECST
 Q