BOPT1 ;IHS/ILC/ALG/CIA/PLS - ILC Send and Receive;07-Mar-2006 12:04;SM
;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
Q
;This rtn loops through the BOP QUEUE file #90355.1
;looking for HL7 messages to build, send or receive.
;ENTRY
GO ; EP
S BOPOOS=$G(^%ZOSF("OS"))
Q:'$D(BOPDIV) Q:'$D(BOPOCK) Q:'$D(BOPIP)
L ^BOP(90355,"S",BOPDIV):1
I '$T G EXIT
N IO
D SETUP^BOPTCP
;IHS exemption approved on March 16, 2005
I XCSNT N $ESTACK,$ETRAP S $ETRAP="D ERROR^BOPTCP"
S CT=0
OPEN D CALL^%ZISTCP(BOPIP,BOPOCK)
G LOOP:'POP S CT=CT+1 H 30 G OPEN:CT<5
Q
LOOP I '$P(^BOP(90355,1,3,BOPDIV,0),U,2) G CLOSE
I +$G(^BOP(90355,1,12))=1 G CLOSE
S COUNTER=0,STOP=0
F S COUNTER=$O(^BOP(90355.1,"AS",0,COUNTER)) Q:COUNTER'>0 Q:STOP D
.S NODE=^BOP(90355.1,COUNTER,0)
.I $P(NODE,U,11)>3 K ^BOP(90355.1,"AS",0,COUNTER) Q
.I $P(NODE,U,2)'="Q03" Q:$P(NODE,U,12)'=BOPDIV&($P(NODE,U,4)'="MFN")
.S STATUS=$P(NODE,"^",10)
.Q:STATUS=99
.;Get BOP Site and Location Decode Code
.S Y=$$SITE^BOPTU(1),BOPITE=$P(Y,U),BOPTYPE=$P(Y,U,2)
.;
.S ACTION=$P(NODE,"^",2)
.K OUT D @ACTION
.S OUT(CONT)=OUT(CONT)_$C(28,13)
.S CT=0
SEND .K IN S BOPACKE=0
.D SDATA^BOPTCP("OUT")
.S $P(^BOP(90355.1,COUNTER,0),U,10)=1
.D GDATA^BOPTCP("IN")
.S RESP=$O(IN(0)) Q:RESP="" D I CT<5,$G(BOPACKE) G SEND
..S HDR=IN(RESP)
..Q:HDR'["MSH"
..I $P(HDR,"|",9)'["ACK" S $P(^BOP(90355.1,COUNTER,0),U,10)=3 Q
..S RESP=$O(IN(RESP)) Q:RESP=""
..S ACK1=IN(RESP)
..I $P(ACK1,"|",2)="AA" S $P(^BOP(90355.1,COUNTER,0),U,10)=9
..I K ^BOP(90355.1,"AS",0,COUNTER),^BOP(90355.1,COUNTER,"O") D ; update node
...N %DT,X,Y S %DT="ST",X="NOW" D ^%DT S ^BOP(90355.1,COUNTER,"O",0)=Y K %DT,X,Y
...I $G(CONT)>0 F AAA=1:1:$G(CONT) S CCC=$G(OUT(AAA)) I CCC'="" F BBB=1:1 S ^BOP(90355.1,COUNTER,"O",AAA,BBB)=$E(CCC,1,252),CCC=$E(CCC,253,$L(CCC)) Q:CCC=""
..I $P(ACK1,"|",2)="AE" S $P(^BOP(90355.1,COUNTER,0),U,10)=3,CT=CT+1 S BOPACKE=1 Q
..I $P(ACK1,"|",2)="AR" S $P(^BOP(90355.1,COUNTER,0),U,10)=3,CT=CT+1 S BOPACKE=1 Q
.I $G(BOPACKE) S C=$P(NODE,U,11)+1,$P(^BOP(90355.1,COUNTER,0),U,11)=C
H 15 G LOOP
CLOSE D CLOSE^%ZISTCP D EXIT
Q
;
A01 ;Build an Admit A01 ;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2,OBXW^BOPT3,OBXH^BOPT3
D DG1^BOPT3,AL1^BOPT3
Q
A02 ;Build a Transfer A02;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
D OBXW^BOPT3,OBXH^BOPT3,DG1^BOPT3,AL1^BOPT3
Q
A03 ;Build a Discharge A03;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
Q
A04 ;Build a Registration A04;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2,OBXW^BOPT3,OBXH^BOPT3
D DG1^BOPT3,AL1^BOPT3
Q
A06 ;Build a Change Out to In pat A06;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
Q
A07 ;Build a Change In to Out pat A07;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
Q
A08 ;Build an Update A08;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
S X=$G(^BOP(90355.1,COUNTER,0)),X=$P(X,"^",21)
I X=1 D OBXH^BOPT3 Q
I X=2 D OBXW^BOPT3 Q
I X=3!(X=5) D DG1^BOPT3 Q
I X=4 D AL1^BOPT3 Q
Q
A11 ;Build a Cancel Admit A11;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
Q
A17 ;Build a Swap Bed
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
Q
A18 ;Build a Merge Info A18;not implemented
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,MRG^BOPT2,PV1^BOPT2
Q
A23 ;Build a Delete Pat A23;
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,PV1^BOPT2
Q
A34 ;Build a Merge ID only A34;not implemented
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,MRG^BOPT2,PV1^BOPT2
Q
A35 ;Build a Merge Account only A35;not implemented
S TYPE="ADT",CONT=0
D MSH^BOPT2,EVN^BOPT2,PID^BOPT2,MRG^BOPT2,PV1^BOPT2
Q
O01 ;Order a Drug O01
;RXC seg. is not implemented as no IV solutions done at this time
S TYPE="RDE",CONT=0
D MSH^BOPT2,PID^BOPT2,PV1^BOPT2,ORC^BOPT3,RXE^BOPT3
I +$P($G(^BOP(90355.1,COUNTER,8)),U,6)=1 D RXC^BOPT3
D RXR^BOPT3
Q
A13 ;FOR an A13;
S TYPE="ADT",CONT=0
D MSH^BOPT2,PID^BOPT2,PV1^BOPT2
Q
Q03 ;Data Link Response
S TYPE="QRY",CONT=0
D MSH^BOPT2
S TIME=$$HLDATE^HLFNC($P(NODE,U,3)),TIME=$P(TIME,"-",1)
S CONT=CONT+1,OUT(CONT)="QRD|"_TIME_"|D|D|ETO|||||ETR|"_$C(13)
S CONT=CONT+1,OUT(CONT)="DSP|"_$C(13)
Q
ERROR ;Set up to send alert
Q
EXIT ;
D PURGE
K COUNTER,NODE,STATUS,ACTION,FLD,ENCD,COM,REP,ESC,SCOM,CONT,RESP
Q
; Loop thru QUEUE and purge eligible records
PURGE ;
N DA,DIK,DTK,EDT,QDT
;Set days to keep (default to 7)
S DTK=$P($G(^BOP(90355,1,4)),U,5) S:'DTK DTK=7
S EDT=$$FMADD^XLFDT(DT,-DTK)
S DIK="^BOP(90355.1,"
F QDT=0 F S QDT=$O(^BOP(90355.1,"B",QDT)) Q:'QDT!(QDT>EDT) D
.S DA=0 F S DA=$O(^BOP(90355.1,"B",QDT,DA)) Q:'DA D
..I $$CANDEL(DA) D
...D ^DIK
Q
; Return a 1 if a queue record can be deleted
CANDEL(IEN) ;
N NODE0
S NODE0=^BOP(90355.1,IEN,0)
I $P(NODE0,U,4)'="",$P(NODE0,U,10)=9 Q 1
I '$L($P($G(^BOP(90355.1,IEN,99)),U,2)) Q 1
I $P(NODE0,U,4)="",$P(^BOP(90355.1,IEN,99),U,2)=9 Q 1
Q 0
BOPT1 ;IHS/ILC/ALG/CIA/PLS - ILC Send and Receive;07-Mar-2006 12:04;SM
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
+2 QUIT
+3 ;This rtn loops through the BOP QUEUE file #90355.1
+4 ;looking for HL7 messages to build, send or receive.
+5 ;ENTRY
GO ; EP
+1 SET BOPOOS=$GET(^%ZOSF("OS"))
+2 IF '$DATA(BOPDIV)
QUIT
IF '$DATA(BOPOCK)
QUIT
IF '$DATA(BOPIP)
QUIT
+3 LOCK ^BOP(90355,"S",BOPDIV):1
+4 IF '$TEST
GOTO EXIT
+5 NEW IO
+6 DO SETUP^BOPTCP
+7 ;IHS exemption approved on March 16, 2005
+8 IF XCSNT
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERROR^BOPTCP"
+9 SET CT=0
OPEN DO CALL^%ZISTCP(BOPIP,BOPOCK)
+1 IF 'POP
GOTO LOOP
SET CT=CT+1
HANG 30
IF CT<5
GOTO OPEN
+2 QUIT
LOOP IF '$PIECE(^BOP(90355,1,3,BOPDIV,0),U,2)
GOTO CLOSE
+1 IF +$GET(^BOP(90355,1,12))=1
GOTO CLOSE
+2 SET COUNTER=0
SET STOP=0
+3 FOR
SET COUNTER=$ORDER(^BOP(90355.1,"AS",0,COUNTER))
IF COUNTER'>0
QUIT
IF STOP
QUIT
Begin DoDot:1
+4 SET NODE=^BOP(90355.1,COUNTER,0)
+5 IF $PIECE(NODE,U,11)>3
KILL ^BOP(90355.1,"AS",0,COUNTER)
QUIT
+6 IF $PIECE(NODE,U,2)'="Q03"
IF $PIECE(NODE,U,12)'=BOPDIV&($PIECE(NODE,U,4)'="MFN")
QUIT
+7 SET STATUS=$PIECE(NODE,"^",10)
+8 IF STATUS=99
QUIT
+9 ;Get BOP Site and Location Decode Code
+10 SET Y=$$SITE^BOPTU(1)
SET BOPITE=$PIECE(Y,U)
SET BOPTYPE=$PIECE(Y,U,2)
+11 ;
+12 SET ACTION=$PIECE(NODE,"^",2)
+13 KILL OUT
DO @ACTION
+14 SET OUT(CONT)=OUT(CONT)_$CHAR(28,13)
+15 SET CT=0
SEND KILL IN
SET BOPACKE=0
+1 DO SDATA^BOPTCP("OUT")
+2 SET $PIECE(^BOP(90355.1,COUNTER,0),U,10)=1
+3 DO GDATA^BOPTCP("IN")
+4 SET RESP=$ORDER(IN(0))
IF RESP=""
QUIT
Begin DoDot:2
+5 SET HDR=IN(RESP)
+6 IF HDR'["MSH"
QUIT
+7 IF $PIECE(HDR,"|",9)'["ACK"
SET $PIECE(^BOP(90355.1,COUNTER,0),U,10)=3
QUIT
+8 SET RESP=$ORDER(IN(RESP))
IF RESP=""
QUIT
+9 SET ACK1=IN(RESP)
+10 IF $PIECE(ACK1,"|",2)="AA"
SET $PIECE(^BOP(90355.1,COUNTER,0),U,10)=9
+11 ; update node
IF $TEST
KILL ^BOP(90355.1,"AS",0,COUNTER),^BOP(90355.1,COUNTER,"O")
Begin DoDot:3
+12 NEW %DT,X,Y
SET %DT="ST"
SET X="NOW"
DO ^%DT
SET ^BOP(90355.1,COUNTER,"O",0)=Y
KILL %DT,X,Y
+13 IF $GET(CONT)>0
FOR AAA=1:1:$GET(CONT)
SET CCC=$GET(OUT(AAA))
IF CCC'=""
FOR BBB=1:1
SET ^BOP(90355.1,COUNTER,"O",AAA,BBB)=$EXTRACT(CCC,1,252)
SET CCC=$EXTRACT(CCC,253,$LENGTH(CCC))
IF CCC=""
QUIT
End DoDot:3
+14 IF $PIECE(ACK1,"|",2)="AE"
SET $PIECE(^BOP(90355.1,COUNTER,0),U,10)=3
SET CT=CT+1
SET BOPACKE=1
QUIT
+15 IF $PIECE(ACK1,"|",2)="AR"
SET $PIECE(^BOP(90355.1,COUNTER,0),U,10)=3
SET CT=CT+1
SET BOPACKE=1
QUIT
End DoDot:2
IF CT<5
IF $GET(BOPACKE)
GOTO SEND
+16 IF $GET(BOPACKE)
SET C=$PIECE(NODE,U,11)+1
SET $PIECE(^BOP(90355.1,COUNTER,0),U,11)=C
End DoDot:1
+17 HANG 15
GOTO LOOP
CLOSE DO CLOSE^%ZISTCP
DO EXIT
+1 QUIT
+2 ;
A01 ;Build an Admit A01 ;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
DO OBXW^BOPT3
DO OBXH^BOPT3
+3 DO DG1^BOPT3
DO AL1^BOPT3
+4 QUIT
A02 ;Build a Transfer A02;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 DO OBXW^BOPT3
DO OBXH^BOPT3
DO DG1^BOPT3
DO AL1^BOPT3
+4 QUIT
A03 ;Build a Discharge A03;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
A04 ;Build a Registration A04;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
DO OBXW^BOPT3
DO OBXH^BOPT3
+3 DO DG1^BOPT3
DO AL1^BOPT3
+4 QUIT
A06 ;Build a Change Out to In pat A06;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
A07 ;Build a Change In to Out pat A07;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
A08 ;Build an Update A08;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 SET X=$GET(^BOP(90355.1,COUNTER,0))
SET X=$PIECE(X,"^",21)
+4 IF X=1
DO OBXH^BOPT3
QUIT
+5 IF X=2
DO OBXW^BOPT3
QUIT
+6 IF X=3!(X=5)
DO DG1^BOPT3
QUIT
+7 IF X=4
DO AL1^BOPT3
QUIT
+8 QUIT
A11 ;Build a Cancel Admit A11;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
A17 ;Build a Swap Bed
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
A18 ;Build a Merge Info A18;not implemented
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO MRG^BOPT2
DO PV1^BOPT2
+3 QUIT
A23 ;Build a Delete Pat A23;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
A34 ;Build a Merge ID only A34;not implemented
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO MRG^BOPT2
DO PV1^BOPT2
+3 QUIT
A35 ;Build a Merge Account only A35;not implemented
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO EVN^BOPT2
DO PID^BOPT2
DO MRG^BOPT2
DO PV1^BOPT2
+3 QUIT
O01 ;Order a Drug O01
+1 ;RXC seg. is not implemented as no IV solutions done at this time
+2 SET TYPE="RDE"
SET CONT=0
+3 DO MSH^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
DO ORC^BOPT3
DO RXE^BOPT3
+4 IF +$PIECE($GET(^BOP(90355.1,COUNTER,8)),U,6)=1
DO RXC^BOPT3
+5 DO RXR^BOPT3
+6 QUIT
A13 ;FOR an A13;
+1 SET TYPE="ADT"
SET CONT=0
+2 DO MSH^BOPT2
DO PID^BOPT2
DO PV1^BOPT2
+3 QUIT
Q03 ;Data Link Response
+1 SET TYPE="QRY"
SET CONT=0
+2 DO MSH^BOPT2
+3 SET TIME=$$HLDATE^HLFNC($PIECE(NODE,U,3))
SET TIME=$PIECE(TIME,"-",1)
+4 SET CONT=CONT+1
SET OUT(CONT)="QRD|"_TIME_"|D|D|ETO|||||ETR|"_$CHAR(13)
+5 SET CONT=CONT+1
SET OUT(CONT)="DSP|"_$CHAR(13)
+6 QUIT
ERROR ;Set up to send alert
+1 QUIT
EXIT ;
+1 DO PURGE
+2 KILL COUNTER,NODE,STATUS,ACTION,FLD,ENCD,COM,REP,ESC,SCOM,CONT,RESP
+3 QUIT
+4 ; Loop thru QUEUE and purge eligible records
PURGE ;
+1 NEW DA,DIK,DTK,EDT,QDT
+2 ;Set days to keep (default to 7)
+3 SET DTK=$PIECE($GET(^BOP(90355,1,4)),U,5)
IF 'DTK
SET DTK=7
+4 SET EDT=$$FMADD^XLFDT(DT,-DTK)
+5 SET DIK="^BOP(90355.1,"
+6 FOR QDT=0
FOR
SET QDT=$ORDER(^BOP(90355.1,"B",QDT))
IF 'QDT!(QDT>EDT)
QUIT
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(^BOP(90355.1,"B",QDT,DA))
IF 'DA
QUIT
Begin DoDot:2
+8 IF $$CANDEL(DA)
Begin DoDot:3
+9 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ; Return a 1 if a queue record can be deleted
CANDEL(IEN) ;
+1 NEW NODE0
+2 SET NODE0=^BOP(90355.1,IEN,0)
+3 IF $PIECE(NODE0,U,4)'=""
IF $PIECE(NODE0,U,10)=9
QUIT 1
+4 IF '$LENGTH($PIECE($GET(^BOP(90355.1,IEN,99)),U,2))
QUIT 1
+5 IF $PIECE(NODE0,U,4)=""
IF $PIECE(^BOP(90355.1,IEN,99),U,2)=9
QUIT 1
+6 QUIT 0
