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

BADECTRL.m

Go to the documentation of this file. 
  1. BADECTRL ; IHS/OIT/FJE/VAC - Dentrix HL7 PROCESS INCOMING EIE MESSAGES ;14-Sep-2010 13:27;EDR
  1.  ;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
  1.  ;; Modified - IHS/MSC/PLS,AMF - 1/12/2011 - receive inbound messages from multiple Dentrix messages
  1.  ;;
  1.  Q
  1.  ;IHS/MSC/AMF 1/12/2011 Modification to support multiple Dentrix messages 
  1. TSK ;EP 
  1.  N MSGDT,MSGTYP,MSGEVT,MSGIEN,QNM,QIEN,PDAYS
  1.  S QNM="RPMS-DEN"
  1.  Q:'$$GETIEN^HLOAPP(QNM)  ;The RPMS-DEN entry in HLO APPLICATION REGISTRY is missing.
  1.  S MSGDT=""
  1.  F  S MSGDT=$O(^HLB("QUEUE","IN",MSGDT)) Q:MSGDT=""  D
  1.  .S MSGTYP=""
  1.  .F  S MSGTYP=$O(^HLB("QUEUE","IN",MSGDT,QNM,MSGTYP)) Q:MSGTYP=""  D
  1.  ..S MSGEVT=""
  1.  ..F  S MSGEVT=$O(^HLB("QUEUE","IN",MSGDT,QNM,MSGTYP,MSGEVT)) Q:MSGEVT=""  D
  1.  ...S MSGIEN=""
  1.  ...F  S MSGIEN=$O(^HLB("QUEUE","IN",MSGDT,QNM,MSGTYP,MSGEVT,MSGIEN)) Q:MSGIEN=""  D
  1.  ....D PROC(MSGIEN)
  1.  Q
  1.  ; Process a single message
  1. PROC(MSGIEN) ;EP
  1.  N PDAYS
  1.  S PDAYS=+$$GET^XPAR("ALL","BADE EDR DEFAULT PURGE DAYS")
  1.  W !,"PDAYS=",PDAYS
  1.  S:'PDAYS PDAYS=7  ;Set default of 7 days
  1.  S ER=""
  1.  D PROCNOW^HLOAPI3(MSGIEN,$$FMADD^XLFDT($$NOW^XLFDT,PDAYS),ER)
  1.  W !,"ERROR=",ER
  1.  K ^HLB("QUEUE","IN",MSGDT,QNM,MSGTYP,MSGEVT,MSGIEN)  ;Remove from "IN" queue
  1.  Q
  1.  ; ----- end IHS/MSC/AMF 1/12/2011 
  1. TSK1 ;This is the code to process DFT/P03 message
  1.  ;This code used to be dot code from previous call
  1.  S:$P(^HLB(BADEIEN,0),U,5)="" $P(^HLB(BADEIEN,0),U,5)="HLO RPMS"
  1.  S:$P(^HLB(BADEIEN,0),U,6)="" $P(^HLB(BADEIEN,0),U,6)="CHARGE RPMS"
  1.  S HLMSGIEN=BADEIEN
  1.  D PROC^BADEHL3
  1.  S X="T+7" D ^%DT
  1.  S $P(^HLB(BADEIEN,0),U,9)=+Y_".1201"
  1.  S $P(^HLB(BADEIEN,0),U,20)="SU"
  1.  S BADETDT=$P(^HLB(BADEIEN,0),U,16)
  1.  I $L(BADETDT) K ^HLB("QUEUE",BADETDT,"RPMS-DEN",BADETYP,BADETRG,BADEIEN)
  1.  Q
  1.  ;
  1. SINGLE ;
  1.  S DIR(0)="N",DIR("A")="Enter HLB IEN to test" D ^DIR K DIR
  1.  Q:Y="^"  S BADEIEN=Y
  1.  Q:'$D(^HLB(BADEIEN,0))
  1.  Q:'$D(^HLB(BADEIEN,1))
  1.  Q:'$D(^HLB(BADEIEN,2))
  1.  D INIT
  1.  S U="^"
  1.  D
  1.  .S BADEX=$G(^HLB(BADEIEN,0))
  1.  .Q:$P(BADEX,U,4)'="I"  ;If message is other than inbound
  1.  .Q:$L($P(BADEX,U,20))  ;If present then message previously processed
  1.  .S BADEMSH=$G(^HLB(BADEIEN,1))_$G(^HLB(BADEIEN,2))
  1.  .S U1=$E(BADEMSH,4,4)
  1.  .S BADESF=$P(BADEMSH,U1,4) Q:'$L(BADESF)
  1.  .S BADESA=$P(BADEMSH,U1,3) Q:'$L(BADESA)
  1.  .Q:BADESF'="Dental"
  1.  .Q:BADESA'="DENTRIX"
  1.  .S BADETYP=$P(BADEMSH,U1,9)
  1.  .S BADETRG=$P(BADETYP,U,2),BADETYP=$P(BADETYP,U,1)
  1.  .Q:'$L(BADETYP)
  1.  .Q:'$L(BADETRG)
  1.  .Q:BADETYP'="DFT"
  1.  .Q:BADETRG'="P03"
  1.  .S:$P(^HLB(BADEIEN,0),U,5)="" $P(^HLB(BADEIEN,0),U,5)="HLO RPMS"
  1.  .S:$P(^HLB(BADEIEN,0),U,6)="" $P(^HLB(BADEIEN,0),U,6)="CHARGE RPMS"
  1.  .;D @BADERUN
  1.  .S HLMSGIEN=BADEIEN
  1.  .D PROC^BADEHL3
  1.  .S X="T+7" D ^%DT
  1.  .S $P(^HLB(BADEIEN,0),U,9)=+Y_".1201"
  1.  .S $P(^HLB(BADEIEN,0),U,20)="SU"
  1.  .S BADETDT=$P(^HLB(BADEIEN,0),U,16)
  1.  .I $L(BADETDT) K ^HLB("QUEUE",BADETDT,"RPMS-DEN",BADETYP,BADETRG,BADEIEN)
  1.  D EXIT
  1.  Q
  1.  ;
  1. INIT ;EP initialize variables
  1.  D ^XBKVAR
  1.  Q
  1.  ;
  1. CTRL ;EP create control array
  1.  S X=0 F  S X=$O(^BADECTRL(X)) Q:+X=0  D
  1.  .S BADECACT=$P($G(^BADECTRL(X,0)),U,2)
  1.  .S BADECRF=$P($G(^BADECTRL(X,0)),U,9)
  1.  .S BADECSA=$P($G(^BADECTRL(X,0)),U,4)
  1.  .S BADECSF=$P($G(^BADECTRL(X,0)),U,3)
  1.  .S BADECTYP=$P($G(^BADECTRL(X,0)),U,5)
  1.  .S BADECTRG=$P($G(^BADECTRL(X,0)),U,6)
  1.  .S BADECTAG=$P($G(^BADECTRL(X,0)),U,7)
  1.  .S BADECRTN=$P($G(^BADECTRL(X,0)),U,8)
  1.  .S BADECLNK=$P($G(^BADECTRL(X,0)),U,10)
  1.  .S BADECQUE=$P($G(^BADECTRL(X,2)),U,1)
  1.  .Q:BADECACT'=1
  1.  .I (BADECRF="")!(BADECSA="")!(BADECSF="")!(BADECTYP="")!(BADECTRG="") Q
  1.  .I (BADECTAG="")!(BADECRTN="")!(BADECLNK="")!(BADECQUE="") Q
  1.  .I '$D(BADETMP(BADECRF,BADECSF,BADECSA,BADECTYP,BADECTRG,X)) D
  1.  ..S BADETMP(BADECRF,BADECSF,BADECSA,BADECTYP,BADECTRG,X)=BADECTAG_"^"_BADECRTN
  1.  ..I $G(BADEQUET)'=1 W !,BADETMP(BADECRF,BADECSF,BADECSA,BADECTYP,BADECTRG,X)
  1.  Q
  1.  ;
  1. SCAN ;EP scan HLB global for new incoming messages
  1.  S U="^"
  1.  ;change to queue node
  1.  S BADEIEN=0 F  S BADEIEN=$O(^HLB(BADEIEN)) Q:+BADEIEN=0  D
  1.  .S BADEX=$G(^HLB(BADEIEN,0))
  1.  .Q:$P(BADEX,U,4)'="I"  ;If message is other than inbound
  1.  .Q:+$P(BADEX,U,20)  ;If DATETIME present then message previously processed
  1.  .I $G(BADEQUET)'=1 W !,"Inbound Message:  ",BADEIEN
  1.  .S BADEMSH=$G(^HLB(BADEIEN,1))_$G(^HLB(BADEIEN,2))
  1.  .S U1=$E(BADEMSH,4,4)
  1.  .S BADERF=$P(BADEMSH,U1,5) Q:'$L(BADERF)  Q:'$D(BADETMP(BADERF))
  1.  .S BADESF=$P(BADEMSH,U1,4) Q:'$L(BADESF)  Q:'$D(BADETMP(BADERF,BADESF))
  1.  .S BADESA=$P(BADEMSH,U1,3) Q:'$L(BADESA)  Q:'$D(BADETMP(BADERF,BADESF,BADESA))
  1.  .S BADETYP=$P(BADEMSH,U1,9)
  1.  .S BADETRG=$P(BADETYP,U,2),BADETYP=$P(BADETYP,U,1)
  1.  .Q:'$L(BADETYP)  Q:'$D(BADETMP(BADERF,BADESF,BADESA,BADETYP))
  1.  .Q:'$L(BADETRG)  Q:'$D(BADETMP(BADERF,BADESF,BADESA,BADETYP,BADETRG))
  1.  .S BADEY=0,BADEY=$O(BADETMP(BADERF,BADESF,BADESA,BADETYP,BADETRG,BADEY)) Q:+BADEY=0  D
  1.  ..S BADERUN=BADETMP(BADERF,BADESF,BADESA,BADETYP,BADETRG,BADEY)
  1.  ..Q:$P(BADERUN,U,1)=""
  1.  ..Q:$P(BADERUN,U,2)=""
  1.  ..I $G(BADEQUET)'=1 W !,BADERF_U1_BADESF_U1_BADESA_U1_BADETYP_U1_BADETRG_U1_BADEY_U1_BADERUN
  1.  ..S:$P(^HLB(BADEIEN,0),U,5)="" $P(^HLB(BADEIEN,0),U,5)=BADECLNK
  1.  ..S:$P(^HLB(BADEIEN,0),U,6)="" $P(^HLB(BADEIEN,0),U,6)=BADECQUE
  1.  ..;S:$P(^HLB(BADEIEN,0),U,7)="" $P(^HLB(BADEIEN,0),U,7)=$P(BADERUN,U,1)
  1.  ..;S:$P(^HLB(BADEIEN,0),U,8)="" $P(^HLB(BADEIEN,0),U,8)=$P(BADERUN,U,2)
  1.  ...D @BADERUN
  1.  ..;I $G(BADEQUET)'=1 W:Y=1 !,"Message processed successfully" H 2
  1.  ..;I $G(BADEQUET)'=1 W:Y=0 !,ERROR H 2
  1.  Q
  1.  ;
  1. EXIT ;EP clean up
  1.  D ^XBKVAR
  1.  K BADETMP,BADEX,BADEY,BADERUN,BADERF,BADESF,BADESA,BADETYP,BADETRG
  1.  K BADECRF,BADECSF,BADECSA,BADECTYP,BADECTRG
  1.  K ^BADECTRL("TASK RUNNING")
  1.  Q
  1.  ;