BOPRNEW1 ;IHS/ILC/ALG/CIA/PLS - ILC Queue Processor;06-Feb-2006 22:12;SM
;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
Q
;This routine should be queued to run or set up as in the automatic
;partition startup process. It should always be running.
;
;Get Lock / Only one process should be running at a time
GO ;TaskMan Entry
L +^BOP(90355.1,"FILER"):1 E Q
;
S X="ERR^BOPRNEW",@^%ZOSF("TRAP")
;Just in case it is started without TaskMan, initialize an environment
S DIQUIET=1 D DT^DICRW
;
;Loop on Queue, looking for transactions that have been received
;
N BOPC,BOPX,BOPXX,BOPDA,BOPSTOP,BOPNONU
S (BOPXX,BOPC)=0
LOOP S BOPXX=$O(^BOP(90355.1,"AC",0,BOPXX))
I +$G(^BOP(90355,1,12))=1 Q ; all interfaces stopped
Q:'$P($G(^BOP(90355,1,"SITE")),U,8) ; Default Clerk must be defined
I 'BOPXX S BOPC=BOPC+1 G HANG
;
;Only process "Ready" & "Fillable" Transactions
S I=$G(^BOP(90355.1,BOPXX,99))
G LOOP:$P(I,U)'=1,LOOP:$P(I,U,2)
;
;Put data into local array
K BOPIN S J=0,I=0
F S I=$O(^BOP(90355.1,BOPXX,"DATA",I)) Q:'I S J=J+1,BOPIN(J)=^(I,0)
;
S BOPDA=BOPXX,BOPSTOP=0,BOPNONU=1
D ACTION
;
;Mark the Transaction processed
S DIE=90355.1,DA=BOPDA,DR="99.1///9" D ^DIE
K ^BOP(90355.1,"AC",0,BOPDA)
;
;Continue to run if Run flag is set.
LOOPQ I +$G(^BOP(90355,1,4)) S BOPC=0 G LOOP
Q
;
HANG ;Loop control if nothing to process
;If nothing ready to work on wait a bit, then try again.
;This process will quit if no transactions are received for an hour.
;If it quits, it will be restarted automatically by the Monitor.
;
H 36 G LOOPQ:BOPC<99
Q
;
ACTION ;Entry from BOPOR to send Acknowledgement
;Initialize
N BOPX
S BOPN="",I=0
F S I=$O(BOPIN(I)) Q:'I D
.S X=$P(BOPIN(I),"|") I X'="" S BOPX(X)=BOPIN(I)
;
;BOPN=MSH Segment
;
F S BOPN=$O(BOPIN(BOPN)) Q:BOPN<1 I $P(BOPIN(BOPN),"|")="MSH" D
.S BOPII=$O(BOPIN(BOPN)) Q:'BOPII
.S BOPQRD=BOPIN(BOPII),ACTION=$P($P(BOPIN(BOPN),"|",9),U)
.I ACTION'["DFT" Q:BOPQRD'["QRD|"
.S X=BOPIN(BOPN),RECAPP=$P(X,"|",3),SNDAPP=$P(X,"|",5)
.S FLD="|",HLFS="|",ENCD="^~\&",HLECH="^~\&",SITE=""
.S COM=$E(ENCD,1),REP=$E(ENCD,2),ESC=$E(ENCD,3),SCOM=$E(ENCD,4)
.S X=^BOP(90355,1,0),PROCID=$P(X,U,12),VERID=$P(X,U,13)
.S MCID=$$NOW^XLFDT(),TIME=$$HLDATE^HLFNC(MCID),TIME=$P(TIME,"-",1)
.;If processing from TCP/IP Listener transmit ACK and Quit
.I ACTION="DFT" D Q
..D DFT^BOPROC(BOPDA)
.I ACTION="ETO" D Q
..D INIT^BOPCAP Q:$D(BOPQ)
..S BOP(.02)="Q03",BOP(.04)="QRY",X=$P($G(BOPX("ZPM")),"|",25)
..S BOPYR=$E(X,1,4),BOPMD=$E(X,5,8),BOPT=$E(X,9,12)
..S BOP(.03)=BOPYR-1700_BOPMD_+("."_BOPT)
..S BOP1="",BOP10=""
..K BOPQ D MSH^BOPCAP Q:$G(BOPQ) D FLAG^BOPCAP
..D DFT^BOPROC(BOPDA)
.I ACTION="EPQ" D Q
..S X=$P(BOPQRD,"|",9) Q:'X
..S X=$O(^DPT("SSN",X,0)) Q:'X
..S (BOPDFN,DFN)=X
..D INIT^BOPCAP Q:$D(BOPQ)
..D PID^BOPCP,PV1^BOPCP
..S BOP(.02)="A01",BOP(.04)="ADT"
..S BOP(10.2)=$G(^DPT(DFN,.1))
..S BOP(10.3)=$P($G(^DPT(DFN,.101)),U)
..S X=$P($G(^DPT(DFN,.1041)),U)
..S BOP(10.4)=$P($G(^VA(200,+X,0)),U)
..S X=$P($G(^DPT(DFN,.105)),U),BOP(10.6)=$P($G(^DGPM(+X,0)),U)
..S BOP(.03)=BOP(10.6)
..S BOP10=U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)
..K BOPQ D MSH^BOPCAP Q:$G(BOPQ) D FLAG^BOPCAP
.I ACTION="EOQ" D Q
..S X=$P(BOPQRD,"|",9) Q:'X S X=$O(^DPT("SSN",X,0)) Q:'X
..S (DFN,PSGP)=X
..F BOPO=0:0 S BOPO=$O(^PS(55,DFN,5,BOPO)) Q:BOPO<1 D
...S BOPN0=$G(^PS(55,DFN,5,BOPO,0)) Q:'BOPN0
...S PSGORD=BOPO ;Order Number
...Q:$P(BOPN0,U,9)'="A" ;Status
...Q:'$P($G(^PS(55,DFN,5,BOPO,4)),U,9) ;Verified
...D NEW^BOPCAP
Q
ERR ;S ^TMP($J,"BOPO","NEW1",$S($G(ZTSK):ZTSK,1:$J))=$$EC^%ZOSV() Q
Q
BOPRNEW1 ;IHS/ILC/ALG/CIA/PLS - ILC Queue Processor;06-Feb-2006 22:12;SM
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
+2 QUIT
+3 ;This routine should be queued to run or set up as in the automatic
+4 ;partition startup process. It should always be running.
+5 ;
+6 ;Get Lock / Only one process should be running at a time
GO ;TaskMan Entry
+1 LOCK +^BOP(90355.1,"FILER"):1
IF '$TEST
QUIT
+2 ;
+3 SET X="ERR^BOPRNEW"
SET @^%ZOSF("TRAP")
+4 ;Just in case it is started without TaskMan, initialize an environment
+5 SET DIQUIET=1
DO DT^DICRW
+6 ;
+7 ;Loop on Queue, looking for transactions that have been received
+8 ;
+9 NEW BOPC,BOPX,BOPXX,BOPDA,BOPSTOP,BOPNONU
+10 SET (BOPXX,BOPC)=0
LOOP SET BOPXX=$ORDER(^BOP(90355.1,"AC",0,BOPXX))
+1 ; all interfaces stopped
IF +$GET(^BOP(90355,1,12))=1
QUIT
+2 ; Default Clerk must be defined
IF '$PIECE($GET(^BOP(90355,1,"SITE")),U,8)
QUIT
+3 IF 'BOPXX
SET BOPC=BOPC+1
GOTO HANG
+4 ;
+5 ;Only process "Ready" & "Fillable" Transactions
+6 SET I=$GET(^BOP(90355.1,BOPXX,99))
+7 IF $PIECE(I,U)'=1
GOTO LOOP
IF $PIECE(I,U,2)
GOTO LOOP
+8 ;
+9 ;Put data into local array
+10 KILL BOPIN
SET J=0
SET I=0
+11 FOR
SET I=$ORDER(^BOP(90355.1,BOPXX,"DATA",I))
IF 'I
QUIT
SET J=J+1
SET BOPIN(J)=^(I,0)
+12 ;
+13 SET BOPDA=BOPXX
SET BOPSTOP=0
SET BOPNONU=1
+14 DO ACTION
+15 ;
+16 ;Mark the Transaction processed
+17 SET DIE=90355.1
SET DA=BOPDA
SET DR="99.1///9"
DO ^DIE
+18 KILL ^BOP(90355.1,"AC",0,BOPDA)
+19 ;
+20 ;Continue to run if Run flag is set.
LOOPQ IF +$GET(^BOP(90355,1,4))
SET BOPC=0
GOTO LOOP
+1 QUIT
+2 ;
HANG ;Loop control if nothing to process
+1 ;If nothing ready to work on wait a bit, then try again.
+2 ;This process will quit if no transactions are received for an hour.
+3 ;If it quits, it will be restarted automatically by the Monitor.
+4 ;
+5 HANG 36
IF BOPC<99
GOTO LOOPQ
+6 QUIT
+7 ;
ACTION ;Entry from BOPOR to send Acknowledgement
+1 ;Initialize
+2 NEW BOPX
+3 SET BOPN=""
SET I=0
+4 FOR
SET I=$ORDER(BOPIN(I))
IF 'I
QUIT
Begin DoDot:1
+5 SET X=$PIECE(BOPIN(I),"|")
IF X'=""
SET BOPX(X)=BOPIN(I)
End DoDot:1
+6 ;
+7 ;BOPN=MSH Segment
+8 ;
+9 FOR
SET BOPN=$ORDER(BOPIN(BOPN))
IF BOPN<1
QUIT
IF $PIECE(BOPIN(BOPN),"|")="MSH"
Begin DoDot:1
+10 SET BOPII=$ORDER(BOPIN(BOPN))
IF 'BOPII
QUIT
+11 SET BOPQRD=BOPIN(BOPII)
SET ACTION=$PIECE($PIECE(BOPIN(BOPN),"|",9),U)
+12 IF ACTION'["DFT"
IF BOPQRD'["QRD|"
QUIT
+13 SET X=BOPIN(BOPN)
SET RECAPP=$PIECE(X,"|",3)
SET SNDAPP=$PIECE(X,"|",5)
+14 SET FLD="|"
SET HLFS="|"
SET ENCD="^~\&"
SET HLECH="^~\&"
SET SITE=""
+15 SET COM=$EXTRACT(ENCD,1)
SET REP=$EXTRACT(ENCD,2)
SET ESC=$EXTRACT(ENCD,3)
SET SCOM=$EXTRACT(ENCD,4)
+16 SET X=^BOP(90355,1,0)
SET PROCID=$PIECE(X,U,12)
SET VERID=$PIECE(X,U,13)
+17 SET MCID=$$NOW^XLFDT()
SET TIME=$$HLDATE^HLFNC(MCID)
SET TIME=$PIECE(TIME,"-",1)
+18 ;If processing from TCP/IP Listener transmit ACK and Quit
+19 IF ACTION="DFT"
Begin DoDot:2
+20 DO DFT^BOPROC(BOPDA)
End DoDot:2
QUIT
+21 IF ACTION="ETO"
Begin DoDot:2
+22 DO INIT^BOPCAP
IF $DATA(BOPQ)
QUIT
+23 SET BOP(.02)="Q03"
SET BOP(.04)="QRY"
SET X=$PIECE($GET(BOPX("ZPM")),"|",25)
+24 SET BOPYR=$EXTRACT(X,1,4)
SET BOPMD=$EXTRACT(X,5,8)
SET BOPT=$EXTRACT(X,9,12)
+25 SET BOP(.03)=BOPYR-1700_BOPMD_+("."_BOPT)
+26 SET BOP1=""
SET BOP10=""
+27 KILL BOPQ
DO MSH^BOPCAP
IF $GET(BOPQ)
QUIT
DO FLAG^BOPCAP
+28 DO DFT^BOPROC(BOPDA)
End DoDot:2
QUIT
+29 IF ACTION="EPQ"
Begin DoDot:2
+30 SET X=$PIECE(BOPQRD,"|",9)
IF 'X
QUIT
+31 SET X=$ORDER(^DPT("SSN",X,0))
IF 'X
QUIT
+32 SET (BOPDFN,DFN)=X
+33 DO INIT^BOPCAP
IF $DATA(BOPQ)
QUIT
+34 DO PID^BOPCP
DO PV1^BOPCP
+35 SET BOP(.02)="A01"
SET BOP(.04)="ADT"
+36 SET BOP(10.2)=$GET(^DPT(DFN,.1))
+37 SET BOP(10.3)=$PIECE($GET(^DPT(DFN,.101)),U)
+38 SET X=$PIECE($GET(^DPT(DFN,.1041)),U)
+39 SET BOP(10.4)=$PIECE($GET(^VA(200,+X,0)),U)
+40 SET X=$PIECE($GET(^DPT(DFN,.105)),U)
SET BOP(10.6)=$PIECE($GET(^DGPM(+X,0)),U)
+41 SET BOP(.03)=BOP(10.6)
+42 SET BOP10=U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)
+43 KILL BOPQ
DO MSH^BOPCAP
IF $GET(BOPQ)
QUIT
DO FLAG^BOPCAP
End DoDot:2
QUIT
+44 IF ACTION="EOQ"
Begin DoDot:2
+45 SET X=$PIECE(BOPQRD,"|",9)
IF 'X
QUIT
SET X=$ORDER(^DPT("SSN",X,0))
IF 'X
QUIT
+46 SET (DFN,PSGP)=X
+47 FOR BOPO=0:0
SET BOPO=$ORDER(^PS(55,DFN,5,BOPO))
IF BOPO<1
QUIT
Begin DoDot:3
+48 SET BOPN0=$GET(^PS(55,DFN,5,BOPO,0))
IF 'BOPN0
QUIT
+49 ;Order Number
SET PSGORD=BOPO
+50 ;Status
IF $PIECE(BOPN0,U,9)'="A"
QUIT
+51 ;Verified
IF '$PIECE($GET(^PS(55,DFN,5,BOPO,4)),U,9)
QUIT
+52 DO NEW^BOPCAP
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+53 QUIT
ERR ;S ^TMP($J,"BOPO","NEW1",$S($G(ZTSK):ZTSK,1:$J))=$$EC^%ZOSV() Q
+1 QUIT
