- 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
