- 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