PRCPHL70 ;WISC/CC-PROCESS QUEUED INCOMING ORDERS ;4/00
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
;
; background job to process 447.1 entries sequentially by IP
; kicked off by TASKMAN option PRCP2 SUPPLY STATION TXN RUN
;
NEWMSG L +^PRCP(447.1,"PROCESS QUEUE"):3 I $T=0 Q
N DA,DIC,DIE,DIK,DR,PRCPDA,PRCPDONE,PRCPMGTP,PRCPSEC,PRCPSIT,X
;
START S PRCPSIT=0
;
; for each site/station
F S PRCPSIT=$O(^PRCP(447.1,"C",PRCPSIT)) Q:'+PRCPSIT D
. S PRCPSEC=0
. ;
. ; for each inventory point at that site/station
. F S PRCPSEC=$O(^PRCP(447.1,"C",PRCPSIT,PRCPSEC)) Q:'+PRCPSEC D
. . S PRCPDA=0,PRCPDONE=0
. . L +^PRCP(445,PRCPSEC,1):3 I $T=0 Q ; lock inventory point items
. . D ADD^PRCPULOC(445,PRCPSEC_"-1",0,"HL7 Transaction Processing")
. . ;
. . ; process each supply station transaction sequentially
. . F S PRCPDA=$O(^PRCP(447.1,"C",PRCPSIT,PRCPSEC,PRCPDA)) Q:'+PRCPDA D I 'PRCPDONE Q ; If not processed sucessfully, don't get next txn
. . . S PRCPMGTP=$P(^PRCP(447.1,PRCPDA,0),"^",5)
. . . L +^PRCP(447.1,PRCPDA):3 I $T=0 Q ; lock file 447.1 entry
. . . ;
. . . ; Quantity on hand queries (OSR^Q06 messages)
. . . I $E(PRCPMGTP,1,3)="OSR" D
. . . . L +^PRCP(445,PRCPSEC,6):1 I $T=0 Q
. . . . D ADD^PRCPULOC(445,PRCPSEC_"-6",0,"HL7 Transaction Processing")
. . . . D GETMSG^PRCPHLQU(PRCPDA,.PRCPDONE)
. . . . L -^PRCP(445,PRCPSEC,6)
. . . . D CLEAR^PRCPULOC(445,PRCPSEC_"-6",0)
. . . . Q
. . . ;
. . . ; Order refill/complete (ORM^O01 messages)
. . . I $E(PRCPMGTP,1,3)="ORM" D PROCESS^PRCPHLPO(PRCPDA,.PRCPDONE)
. . . ;
. . . ; Item Utilization/Adjustments (RAS^O01 messages)
. . . I $E(PRCPMGTP,1,3)="RAS" D PROCESS^PRCPHLUT(PRCPDA,.PRCPDONE)
. . . ;
. . . ; maintain 447.1
. . . I PRCPDONE D ; processed successfully, kill entry
. . . . S DA=PRCPDA,DIK="^PRCP(447.1," D ^DIK
. . . ;
. . . L -^PRCP(447.1,PRCPDA)
. . ;
. . L -^PRCP(445,PRCPSEC,1)
. . D CLEAR^PRCPULOC(445,PRCPSEC_"-1",0)
;
Q I $O(^PRCP(447.1,0))]"" G START ; loop until queue is empty
L -^PRCP(447.1,"PROCESS QUEUE")
Q
;
;
NAME(PRCPSEC,ITEM,NAME,TYPE,PRCPHL7) ; notify users of name mismatches
;
; PRCPSEC secondary inventory point ien
; ITEM item's ien
; NAME item name as it appears on the supply station
; TYPE supply station approach to item names
; O = only 1 name per item per system
; S = each station may have different name for same item
; PRCPHL7 (file 773 IEN).(file 772 IEN).447.1 for the HL7 transaction
;
N PRCPXMY,USER,XMB,XMDUZ,XMTEXT
S ^TMP($J,"PRCPHL7",1,1,0)=" " ; blank line
I TYPE="S" S ^TMP($J,"PRCPHL7",1,2,0)="ON GIP: "_$P($G(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
I TYPE="O" S ^TMP($J,"PRCPHL7",1,2,0)="ON GIP: "_$P($G(^PRC(441,ITEM,0)),"^",2)
S ^TMP($J,"PRCPHL7",1,3,0)="STATION: "_NAME
S ^TMP($J,"PRCPHL7",1,4,0)=""
S ^TMP($J,"PRCPHL7",1,5,0)=""
I PRCPHL7 S ^TMP($J,"PRCPHL7",1,5,0)="(Information acquired from HL7 txn# "_PRCPHL7_")"
S ^TMP($J,"PRCPHL7",1)=5
D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY("")) ; send message to primary inventory point users
S USER=0
; restrict message to managers
F S USER=$O(PRCPXMY(USER)) Q:USER'>0 I PRCPXMY(USER)=1 S XMY(USER)=""
S XMTEXT="^TMP($J,""PRCPHL7"",1,"
S XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
S XMB(2)=ITEM
S XMB="PRCP_ITEM_NAME"
S XMDUZ="SUPPLY STATION INTERFACE"
D EN^XMB
K ^TMP($J,"PRCPHL7")
Q
;
;
QTYDISC(PRCPSEC,PRCPITEM,PRCPITNM,QTY,PRCPLEFT,PRCPHL7) ; tell user qty left is wrong
;
; PRCPSEC = the secondary IP ien
; PRCPITEM = the item ien
; PRCPITNM = the item name from the transaction
; QTY = the actual quantity in GIP after this transaction
; PRCPLEFT = the quantity on the supply station after this transaction
; PRCPHL7 = (file 773 IEN).(file 772 IEN).447.1 for the HL7 transaction
;
N ITEM,PRCPXMY,REFILL,XMB,XMDUZ,XMTEXT,XMY
D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY("")) ; quit if no users in inv point
S ITEM=0
; restrict message to managers
F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
K ^TMP($J,"PRCPHL7")
S XMTEXT="^TMP($J,""PRCPHL7"",1,"
S REFILL=$$REFILLS^PRCPRDIS(PRCPITEM,PRCPSEC) I REFILL]"" D
. S ^TMP($J,"PRCPHL7",1,1,0)=" "
. S ^TMP($J,"PRCPHL7",1,2,0)=" "
. S ^TMP($J,"PRCPHL7",1,3,0)="NOTE: This item has "_$P(REFILL,":",1)_" on:"
. S ^TMP($J,"PRCPHL7",1,4,0)=$P(REFILL,":",2)
. S ^TMP($J,"PRCPHL7",1)=4
S XMB="PRCP_QTY_MISMATCH"
S XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
S XMB(2)=PRCPITNM_" ("_PRCPITEM_")"
S XMB(3)=QTY
S XMB(4)=PRCPLEFT
S XMB(5)=PRCPHL7
S XMDUZ="SUPPLY STATION INTERFACE"
D EN^XMB
K ^TMP($J,"PRCPHL7")
Q
;
;
; cleans out file 447.1 - not invoked by any routine or option
CLEAN N A,DA,DIK
S A=0
S DIK="^PRCP(447.1,"
F S A=$O(^PRCP(447.1,A)) Q:'+A S DA=A D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHL70 4937 printed Mar 13, 2024@23:27:56 Page 2
PRCPHL70 ;WISC/CC-PROCESS QUEUED INCOMING ORDERS ;4/00
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 QUIT
+4 ;
+5 ; background job to process 447.1 entries sequentially by IP
+6 ; kicked off by TASKMAN option PRCP2 SUPPLY STATION TXN RUN
+7 ;
NEWMSG LOCK +^PRCP(447.1,"PROCESS QUEUE"):3
IF $TEST=0
QUIT
+1 NEW DA,DIC,DIE,DIK,DR,PRCPDA,PRCPDONE,PRCPMGTP,PRCPSEC,PRCPSIT,X
+2 ;
START SET PRCPSIT=0
+1 ;
+2 ; for each site/station
+3 FOR
SET PRCPSIT=$ORDER(^PRCP(447.1,"C",PRCPSIT))
if '+PRCPSIT
QUIT
Begin DoDot:1
+4 SET PRCPSEC=0
+5 ;
+6 ; for each inventory point at that site/station
+7 FOR
SET PRCPSEC=$ORDER(^PRCP(447.1,"C",PRCPSIT,PRCPSEC))
if '+PRCPSEC
QUIT
Begin DoDot:2
+8 SET PRCPDA=0
SET PRCPDONE=0
+9 ; lock inventory point items
LOCK +^PRCP(445,PRCPSEC,1):3
IF $TEST=0
QUIT
+10 DO ADD^PRCPULOC(445,PRCPSEC_"-1",0,"HL7 Transaction Processing")
+11 ;
+12 ; process each supply station transaction sequentially
+13 ; If not processed sucessfully, don't get next txn
FOR
SET PRCPDA=$ORDER(^PRCP(447.1,"C",PRCPSIT,PRCPSEC,PRCPDA))
if '+PRCPDA
QUIT
Begin DoDot:3
+14 SET PRCPMGTP=$PIECE(^PRCP(447.1,PRCPDA,0),"^",5)
+15 ; lock file 447.1 entry
LOCK +^PRCP(447.1,PRCPDA):3
IF $TEST=0
QUIT
+16 ;
+17 ; Quantity on hand queries (OSR^Q06 messages)
+18 IF $EXTRACT(PRCPMGTP,1,3)="OSR"
Begin DoDot:4
+19 LOCK +^PRCP(445,PRCPSEC,6):1
IF $TEST=0
QUIT
+20 DO ADD^PRCPULOC(445,PRCPSEC_"-6",0,"HL7 Transaction Processing")
+21 DO GETMSG^PRCPHLQU(PRCPDA,.PRCPDONE)
+22 LOCK -^PRCP(445,PRCPSEC,6)
+23 DO CLEAR^PRCPULOC(445,PRCPSEC_"-6",0)
+24 QUIT
End DoDot:4
+25 ;
+26 ; Order refill/complete (ORM^O01 messages)
+27 IF $EXTRACT(PRCPMGTP,1,3)="ORM"
DO PROCESS^PRCPHLPO(PRCPDA,.PRCPDONE)
+28 ;
+29 ; Item Utilization/Adjustments (RAS^O01 messages)
+30 IF $EXTRACT(PRCPMGTP,1,3)="RAS"
DO PROCESS^PRCPHLUT(PRCPDA,.PRCPDONE)
+31 ;
+32 ; maintain 447.1
+33 ; processed successfully, kill entry
IF PRCPDONE
Begin DoDot:4
+34 SET DA=PRCPDA
SET DIK="^PRCP(447.1,"
DO ^DIK
End DoDot:4
+35 ;
+36 LOCK -^PRCP(447.1,PRCPDA)
End DoDot:3
IF 'PRCPDONE
QUIT
+37 ;
+38 LOCK -^PRCP(445,PRCPSEC,1)
+39 DO CLEAR^PRCPULOC(445,PRCPSEC_"-1",0)
End DoDot:2
End DoDot:1
+40 ;
Q ; loop until queue is empty
IF $ORDER(^PRCP(447.1,0))]""
GOTO START
+1 LOCK -^PRCP(447.1,"PROCESS QUEUE")
+2 QUIT
+3 ;
+4 ;
NAME(PRCPSEC,ITEM,NAME,TYPE,PRCPHL7) ; notify users of name mismatches
+1 ;
+2 ; PRCPSEC secondary inventory point ien
+3 ; ITEM item's ien
+4 ; NAME item name as it appears on the supply station
+5 ; TYPE supply station approach to item names
+6 ; O = only 1 name per item per system
+7 ; S = each station may have different name for same item
+8 ; PRCPHL7 (file 773 IEN).(file 772 IEN).447.1 for the HL7 transaction
+9 ;
+10 NEW PRCPXMY,USER,XMB,XMDUZ,XMTEXT
+11 ; blank line
SET ^TMP($JOB,"PRCPHL7",1,1,0)=" "
+12 IF TYPE="S"
SET ^TMP($JOB,"PRCPHL7",1,2,0)="ON GIP: "_$PIECE($GET(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
+13 IF TYPE="O"
SET ^TMP($JOB,"PRCPHL7",1,2,0)="ON GIP: "_$PIECE($GET(^PRC(441,ITEM,0)),"^",2)
+14 SET ^TMP($JOB,"PRCPHL7",1,3,0)="STATION: "_NAME
+15 SET ^TMP($JOB,"PRCPHL7",1,4,0)=""
+16 SET ^TMP($JOB,"PRCPHL7",1,5,0)=""
+17 IF PRCPHL7
SET ^TMP($JOB,"PRCPHL7",1,5,0)="(Information acquired from HL7 txn# "_PRCPHL7_")"
+18 SET ^TMP($JOB,"PRCPHL7",1)=5
+19 ; send message to primary inventory point users
DO GETUSER^PRCPXTRM(PRCPSEC)
if '$ORDER(PRCPXMY(""))
QUIT
+20 SET USER=0
+21 ; restrict message to managers
+22 FOR
SET USER=$ORDER(PRCPXMY(USER))
if USER'>0
QUIT
IF PRCPXMY(USER)=1
SET XMY(USER)=""
+23 SET XMTEXT="^TMP($J,""PRCPHL7"",1,"
+24 SET XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
+25 SET XMB(2)=ITEM
+26 SET XMB="PRCP_ITEM_NAME"
+27 SET XMDUZ="SUPPLY STATION INTERFACE"
+28 DO EN^XMB
+29 KILL ^TMP($JOB,"PRCPHL7")
+30 QUIT
+31 ;
+32 ;
QTYDISC(PRCPSEC,PRCPITEM,PRCPITNM,QTY,PRCPLEFT,PRCPHL7) ; tell user qty left is wrong
+1 ;
+2 ; PRCPSEC = the secondary IP ien
+3 ; PRCPITEM = the item ien
+4 ; PRCPITNM = the item name from the transaction
+5 ; QTY = the actual quantity in GIP after this transaction
+6 ; PRCPLEFT = the quantity on the supply station after this transaction
+7 ; PRCPHL7 = (file 773 IEN).(file 772 IEN).447.1 for the HL7 transaction
+8 ;
+9 NEW ITEM,PRCPXMY,REFILL,XMB,XMDUZ,XMTEXT,XMY
+10 ; quit if no users in inv point
DO GETUSER^PRCPXTRM(PRCPSEC)
if '$ORDER(PRCPXMY(""))
QUIT
+11 SET ITEM=0
+12 ; restrict message to managers
+13 FOR
SET ITEM=$ORDER(PRCPXMY(ITEM))
if ITEM'>0
QUIT
IF PRCPXMY(ITEM)=1
SET XMY(ITEM)=""
+14 KILL ^TMP($JOB,"PRCPHL7")
+15 SET XMTEXT="^TMP($J,""PRCPHL7"",1,"
+16 SET REFILL=$$REFILLS^PRCPRDIS(PRCPITEM,PRCPSEC)
IF REFILL]""
Begin DoDot:1
+17 SET ^TMP($JOB,"PRCPHL7",1,1,0)=" "
+18 SET ^TMP($JOB,"PRCPHL7",1,2,0)=" "
+19 SET ^TMP($JOB,"PRCPHL7",1,3,0)="NOTE: This item has "_$PIECE(REFILL,":",1)_" on:"
+20 SET ^TMP($JOB,"PRCPHL7",1,4,0)=$PIECE(REFILL,":",2)
+21 SET ^TMP($JOB,"PRCPHL7",1)=4
End DoDot:1
+22 SET XMB="PRCP_QTY_MISMATCH"
+23 SET XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
+24 SET XMB(2)=PRCPITNM_" ("_PRCPITEM_")"
+25 SET XMB(3)=QTY
+26 SET XMB(4)=PRCPLEFT
+27 SET XMB(5)=PRCPHL7
+28 SET XMDUZ="SUPPLY STATION INTERFACE"
+29 DO EN^XMB
+30 KILL ^TMP($JOB,"PRCPHL7")
+31 QUIT
+32 ;
+33 ;
+34 ; cleans out file 447.1 - not invoked by any routine or option
CLEAN NEW A,DA,DIK
+1 SET A=0
+2 SET DIK="^PRCP(447.1,"
+3 FOR
SET A=$ORDER(^PRCP(447.1,A))
if '+A
QUIT
SET DA=A
DO ^DIK
+4 QUIT