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