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

BOPT1.m

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