PRCPHLPO ;WISC/CC-REFILL AND POST ORDER FROM 447.1 ENTRY ;4/00
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
PROCESS(PRCPDA,PRCPDONE) ;
N CONV,DIE,DR,ERR,I,ITEM,LOCKORD,LOCKPRIM,ORDERDA,X,PRCPITDA,PRIM
N PRCPAMT,PRCPDATA,PRCPHL7,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPNOIT
N PRCPORD,PRCPPOST,PRCPPRIM,PRCPSECO,PRCPSS,PRCPSSFL,PRCPTIME,PRCPUSER
;
S PRCPDONE=0,LOCKORD=0,LOCKPRIM=0,ERR=0
S PRCPDATA=^PRCP(447.1,PRCPDA,0)
S PRCPHL7=$P(PRCPDATA,"^",6)_".447.1"
S ORDERDA=$P(PRCPDATA,"^",7)
S PRCPSECO=$P(PRCPDATA,"^",3)
S PRCPTIME=$P(PRCPDATA,"^",8)
S PRCPUSER=$P(PRCPDATA,"^",10)
S PRCPPOST=$P(PRCPDATA,"^",11)
;
L +^PRCP(445.3,ORDERDA):3 I $T=0 S PRCPDONE=0 Q
D ADD^PRCPULOC(445.3,ORDERDA_"-1",0,"HL7 Distribution Order Processing")
S LOCKORD=1
;
I PRCPPOST'="FU" D I $D(ERR),+ERR>0 G ERR
. S PRCPITDA=0
. S PRCPITDA=$O(^PRCP(447.1,PRCPDA,1,PRCPITDA))
. I '+PRCPITDA S ERR="6F" Q ; no item in transaction
. S PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
. S PRCPITEM=$P(PRCPDATA,"^",1)
. S PRCPAMT=$P(PRCPDATA,"^",3) ; REFILL QTY - restock issue units
. S PRCPLEFT=$P(PRCPDATA,"^",2)
. S PRCPITNM=$P(PRCPDATA,"^",4)
;
I '$D(^PRCP(445.3,ORDERDA)) S ERR="2A" G ERR ; order not in GIP
S PRCPPRIM=$P(^PRCP(445.3,ORDERDA,0),"^",2)
I $P(^PRCP(445.3,ORDERDA,0),"^",6)="P" S ERR="2B" G ERR ; order is posted
I $P(^PRCP(445.3,ORDERDA,0),"^",10)']"" S ERR="2C" G ERR ; order not to be completed by supply station
I '$D(^PRCP(445,PRCPSECO)) S ERR="3A" G ERR ; secondary not in GIP
I $P(^PRCP(445,PRCPSECO,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
I PRCPPOST="FU" D G:ERR>0 ERR G UPDATE
. I $P($G(^PRCP(445,PRCPSECO,5)),"^",1)']"" S ERR="3F" ; not a supply station secondary
;
I PRCPITDA']"" S ERR="6F" G ERR ; no item information
I '$D(^PRCP(445.3,ORDERDA,1,PRCPITEM)) S ERR="6A" G ERR ; not on the GIP order"
I '$D(^PRCP(445,PRCPSECO,1,PRCPITEM)) S ERR="6C" G ERR ; "Not in this inventory point"
I $P(^PRCP(445,PRCPSECO,1,PRCPITEM,0),"^",9)'>0 S ERR="6D" G ERR ; not flagged as a supply station item"
I '$D(^PRCP(445,PRCPPRIM,1,PRCPITEM)) S ERR="6B" G ERR ; not in the primary"
I $P($G(^PRCP(445,PRCPSECO,5)),"^",1)']"" S ERR="3F" G ERR ; not a supply station secondary
I $P($G(^PRC(441,PRCPITEM,0)),"^",6)="S" S ERR="6G" G ERR ; case cart/ik
; compare name in 445 with name sent, notify user if mismatch, CONTINUE
S PRCPSSFL=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSECO,5),"^",1),0),"^",2)
; if item name on supply station comes from item master
I PRCPSSFL="O",$P(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM D NAME^PRCPHL70(PRCPSECO,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
; if item name on supply station is from the secondary
I PRCPSSFL="S",$G(^PRCP(445,PRCPSECO,1,PRCPITEM,6))'=PRCPITNM D NAME^PRCPHL70(PRCPSECO,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
;
UPDATE I $P(^PRCP(445.3,ORDERDA,0),"^",6)="P" S ERR="2B" G ERR ; order is posted
I PRCPPOST'="FU",'$D(^PRCP(445.3,ORDERDA,1,PRCPITEM)) S ERR="6D" G ERR ; item not on order
I PRCPPOST'="FU" D G Q ; add amount received to order
. S DIE="^PRCP(445.3,"_ORDERDA_",1,"
. S DA=PRCPITEM
. ; the following lines handle the case on an item in multiple bins
. ; The user receiving an item in multiple bins will generate one
. ; transaction per bin.
. S X=$P($G(^PRCP(445.3,ORDERDA,1,DA,0)),"^",7)+0 ; amt refilled so far
. S PRCPAMT=PRCPAMT+X
. S DR="6///^S X=PRCPAMT"
. D ^DIE K DIE
. S PRCPDONE=1
. ;
. S ^PRCP(445,PRCPSECO,1,PRCPITEM,9)=PRCPLEFT_"^"_PRCPTIME
;
I PRCPPOST="FU" D G Q
. S PRCPSS=1
. L +^PRCP(445,PRCPPRIM,1):3 I $T=0 S PRCPDONE=0 Q
. S LOCKPRIM=1
. D ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"HL7 Distribution Order Processing")
. D PRCPSS^PRCPOPP(ORDERDA,PRCPSECO,PRCPPRIM,PRCPSS)
. S PRCPDONE=1
. ; verify each item has refill amount
. S ITEM=0
. F S ITEM=$O(^PRCP(445.3,ORDERDA,1,ITEM)) Q:'ITEM D
. . S X=$P($G(^PRCP(445.3,ORDERDA,1,ITEM,0)),"^",7)
. . I X']"" S PRCPNOIT(ITEM)=1
. I $D(PRCPNOIT) D ; send message for items not refilled
. . N ITEMNM,LN,PRCPXMY,TYPE,XMB,XMDUZ,XMTEXT,XMY
. . K ^TMP($J,"PRCPHL7")
. . S ITEM=0,LN=0
. . F S ITEM=$O(PRCPNOIT(ITEM)) Q:'ITEM D
. . . S LN=LN+1
. . . S ITEMNM=$P($G(^PRCP(445,PRCPSECO,1,ITEM,6)),"^",1)
. . . I ITEMNM']"" S TYPE=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSECO,5),"^",1),0),"^",2) D
. . . . I TYPE="S" S ITEMNM=$P($G(^PRCP(445,PRCPPRIM,1,ITEM,6)),"^",1)
. . . . I TYPE="O" S ITEMNM=$P($G(^PRC(441,ITEM,0)),"^",2)
. . . S ^TMP($J,"PRCPHL7",1,LN,0)=$E(" ",$L(ITEM),7)_ITEM_" "_ITEMNM
. . S ^TMP($J,"PRCPHL7",1,0)=LN
. . D GETUSER^PRCPXTRM(PRCPPRIM) Q:'$O(PRCPXMY("")) ; find primary inventory point users
. . S ITEM=0
. . ; restrict message to inventory point managers
. . F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
. . S XMTEXT="^TMP($J,""PRCPHL7"",1,"
. . S XMB(1)=$P(^PRCP(445.3,ORDERDA,0),"^",1)
. . S XMB(3)=$$INVNAME^PRCPUX1(PRCPSECO)
. . S XMB(2)=$P(^PRCP(445,$P(^PRCP(445.3,ORDERDA,0),"^",2),0),"^",1)
. . S XMB="PRCP_NO_REFILL"
. . S XMDUZ="SUPPLY STATION INTERFACE"
. . D EN^XMB
. . K ^TMP($J,"PRCPHL7")
;
ERR ;
N NUMBER,PRCPHLPO
S NUMBER=ERR
S PRCPHLPO("ORDER")=$P($G(^PRCP(445.3,ORDERDA,0)),"^",1)
S PRCPHLPO("SIPNAME")="" I $D(^PRCP(445,PRCPSECO)) S PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSECO)
S PRCPHLPO("ITEM")="" I $D(PRCPITEM) S PRCPHLPO("ITEM")=PRCPITEM
S PRCPHLPO("NAME")="" I $D(PRCPITNM) S PRCPHLPO("NAME")=PRCPITNM
S PRCPHLPO("QTY")="" I $D(PRCPAMT) S PRCPHLPO("QTY")=PRCPAMT
S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
S PRCPHLPO("TYPE")="" I $D(PRCPPOST) S PRCPHLPO("TYPE")=PRCPPOST
D ERR^PRCPHLM0(ERR,"PRCP_BAD_ORDER",PRCPSECO,.PRCPHLPO,PRCPHL7)
S PRCPDONE=1
;
Q I LOCKORD L -^PRCP(445.3,ORDERDA) D CLEAR^PRCPULOC(445.3,ORDERDA_"-1",0)
I LOCKPRIM L -^PRCP(445,PRCPPRIM,1) D CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLPO 5979 printed Oct 16, 2024@18:14:40 Page 2
PRCPHLPO ;WISC/CC-REFILL AND POST ORDER FROM 447.1 ENTRY ;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 ;
PROCESS(PRCPDA,PRCPDONE) ;
+1 NEW CONV,DIE,DR,ERR,I,ITEM,LOCKORD,LOCKPRIM,ORDERDA,X,PRCPITDA,PRIM
+2 NEW PRCPAMT,PRCPDATA,PRCPHL7,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPNOIT
+3 NEW PRCPORD,PRCPPOST,PRCPPRIM,PRCPSECO,PRCPSS,PRCPSSFL,PRCPTIME,PRCPUSER
+4 ;
+5 SET PRCPDONE=0
SET LOCKORD=0
SET LOCKPRIM=0
SET ERR=0
+6 SET PRCPDATA=^PRCP(447.1,PRCPDA,0)
+7 SET PRCPHL7=$PIECE(PRCPDATA,"^",6)_".447.1"
+8 SET ORDERDA=$PIECE(PRCPDATA,"^",7)
+9 SET PRCPSECO=$PIECE(PRCPDATA,"^",3)
+10 SET PRCPTIME=$PIECE(PRCPDATA,"^",8)
+11 SET PRCPUSER=$PIECE(PRCPDATA,"^",10)
+12 SET PRCPPOST=$PIECE(PRCPDATA,"^",11)
+13 ;
+14 LOCK +^PRCP(445.3,ORDERDA):3
IF $TEST=0
SET PRCPDONE=0
QUIT
+15 DO ADD^PRCPULOC(445.3,ORDERDA_"-1",0,"HL7 Distribution Order Processing")
+16 SET LOCKORD=1
+17 ;
+18 IF PRCPPOST'="FU"
Begin DoDot:1
+19 SET PRCPITDA=0
+20 SET PRCPITDA=$ORDER(^PRCP(447.1,PRCPDA,1,PRCPITDA))
+21 ; no item in transaction
IF '+PRCPITDA
SET ERR="6F"
QUIT
+22 SET PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
+23 SET PRCPITEM=$PIECE(PRCPDATA,"^",1)
+24 ; REFILL QTY - restock issue units
SET PRCPAMT=$PIECE(PRCPDATA,"^",3)
+25 SET PRCPLEFT=$PIECE(PRCPDATA,"^",2)
+26 SET PRCPITNM=$PIECE(PRCPDATA,"^",4)
End DoDot:1
IF $DATA(ERR)
IF +ERR>0
GOTO ERR
+27 ;
+28 ; order not in GIP
IF '$DATA(^PRCP(445.3,ORDERDA))
SET ERR="2A"
GOTO ERR
+29 SET PRCPPRIM=$PIECE(^PRCP(445.3,ORDERDA,0),"^",2)
+30 ; order is posted
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",6)="P"
SET ERR="2B"
GOTO ERR
+31 ; order not to be completed by supply station
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",10)']""
SET ERR="2C"
GOTO ERR
+32 ; secondary not in GIP
IF '$DATA(^PRCP(445,PRCPSECO))
SET ERR="3A"
GOTO ERR
+33 ; not a secondary
IF $PIECE(^PRCP(445,PRCPSECO,0),"^",3)'="S"
SET ERR="3B"
GOTO ERR
+34 IF PRCPPOST="FU"
Begin DoDot:1
+35 ; not a supply station secondary
IF $PIECE($GET(^PRCP(445,PRCPSECO,5)),"^",1)']""
SET ERR="3F"
End DoDot:1
if ERR>0
GOTO ERR
GOTO UPDATE
+36 ;
+37 ; no item information
IF PRCPITDA']""
SET ERR="6F"
GOTO ERR
+38 ; not on the GIP order"
IF '$DATA(^PRCP(445.3,ORDERDA,1,PRCPITEM))
SET ERR="6A"
GOTO ERR
+39 ; "Not in this inventory point"
IF '$DATA(^PRCP(445,PRCPSECO,1,PRCPITEM))
SET ERR="6C"
GOTO ERR
+40 ; not flagged as a supply station item"
IF $PIECE(^PRCP(445,PRCPSECO,1,PRCPITEM,0),"^",9)'>0
SET ERR="6D"
GOTO ERR
+41 ; not in the primary"
IF '$DATA(^PRCP(445,PRCPPRIM,1,PRCPITEM))
SET ERR="6B"
GOTO ERR
+42 ; not a supply station secondary
IF $PIECE($GET(^PRCP(445,PRCPSECO,5)),"^",1)']""
SET ERR="3F"
GOTO ERR
+43 ; case cart/ik
IF $PIECE($GET(^PRC(441,PRCPITEM,0)),"^",6)="S"
SET ERR="6G"
GOTO ERR
+44 ; compare name in 445 with name sent, notify user if mismatch, CONTINUE
+45 SET PRCPSSFL=$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,PRCPSECO,5),"^",1),0),"^",2)
+46 ; if item name on supply station comes from item master
+47 IF PRCPSSFL="O"
IF $PIECE(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM
DO NAME^PRCPHL70(PRCPSECO,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
+48 ; if item name on supply station is from the secondary
+49 IF PRCPSSFL="S"
IF $GET(^PRCP(445,PRCPSECO,1,PRCPITEM,6))'=PRCPITNM
DO NAME^PRCPHL70(PRCPSECO,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
+50 ;
UPDATE ; order is posted
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",6)="P"
SET ERR="2B"
GOTO ERR
+1 ; item not on order
IF PRCPPOST'="FU"
IF '$DATA(^PRCP(445.3,ORDERDA,1,PRCPITEM))
SET ERR="6D"
GOTO ERR
+2 ; add amount received to order
IF PRCPPOST'="FU"
Begin DoDot:1
+3 SET DIE="^PRCP(445.3,"_ORDERDA_",1,"
+4 SET DA=PRCPITEM
+5 ; the following lines handle the case on an item in multiple bins
+6 ; The user receiving an item in multiple bins will generate one
+7 ; transaction per bin.
+8 ; amt refilled so far
SET X=$PIECE($GET(^PRCP(445.3,ORDERDA,1,DA,0)),"^",7)+0
+9 SET PRCPAMT=PRCPAMT+X
+10 SET DR="6///^S X=PRCPAMT"
+11 DO ^DIE
KILL DIE
+12 SET PRCPDONE=1
+13 ;
+14 SET ^PRCP(445,PRCPSECO,1,PRCPITEM,9)=PRCPLEFT_"^"_PRCPTIME
End DoDot:1
GOTO Q
+15 ;
+16 IF PRCPPOST="FU"
Begin DoDot:1
+17 SET PRCPSS=1
+18 LOCK +^PRCP(445,PRCPPRIM,1):3
IF $TEST=0
SET PRCPDONE=0
QUIT
+19 SET LOCKPRIM=1
+20 DO ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"HL7 Distribution Order Processing")
+21 DO PRCPSS^PRCPOPP(ORDERDA,PRCPSECO,PRCPPRIM,PRCPSS)
+22 SET PRCPDONE=1
+23 ; verify each item has refill amount
+24 SET ITEM=0
+25 FOR
SET ITEM=$ORDER(^PRCP(445.3,ORDERDA,1,ITEM))
if 'ITEM
QUIT
Begin DoDot:2
+26 SET X=$PIECE($GET(^PRCP(445.3,ORDERDA,1,ITEM,0)),"^",7)
+27 IF X']""
SET PRCPNOIT(ITEM)=1
End DoDot:2
+28 ; send message for items not refilled
IF $DATA(PRCPNOIT)
Begin DoDot:2
+29 NEW ITEMNM,LN,PRCPXMY,TYPE,XMB,XMDUZ,XMTEXT,XMY
+30 KILL ^TMP($JOB,"PRCPHL7")
+31 SET ITEM=0
SET LN=0
+32 FOR
SET ITEM=$ORDER(PRCPNOIT(ITEM))
if 'ITEM
QUIT
Begin DoDot:3
+33 SET LN=LN+1
+34 SET ITEMNM=$PIECE($GET(^PRCP(445,PRCPSECO,1,ITEM,6)),"^",1)
+35 IF ITEMNM']""
SET TYPE=$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,PRCPSECO,5),"^",1),0),"^",2)
Begin DoDot:4
+36 IF TYPE="S"
SET ITEMNM=$PIECE($GET(^PRCP(445,PRCPPRIM,1,ITEM,6)),"^",1)
+37 IF TYPE="O"
SET ITEMNM=$PIECE($GET(^PRC(441,ITEM,0)),"^",2)
End DoDot:4
+38 SET ^TMP($JOB,"PRCPHL7",1,LN,0)=$EXTRACT(" ",$LENGTH(ITEM),7)_ITEM_" "_ITEMNM
End DoDot:3
+39 SET ^TMP($JOB,"PRCPHL7",1,0)=LN
+40 ; find primary inventory point users
DO GETUSER^PRCPXTRM(PRCPPRIM)
if '$ORDER(PRCPXMY(""))
QUIT
+41 SET ITEM=0
+42 ; restrict message to inventory point managers
+43 FOR
SET ITEM=$ORDER(PRCPXMY(ITEM))
if ITEM'>0
QUIT
IF PRCPXMY(ITEM)=1
SET XMY(ITEM)=""
+44 SET XMTEXT="^TMP($J,""PRCPHL7"",1,"
+45 SET XMB(1)=$PIECE(^PRCP(445.3,ORDERDA,0),"^",1)
+46 SET XMB(3)=$$INVNAME^PRCPUX1(PRCPSECO)
+47 SET XMB(2)=$PIECE(^PRCP(445,$PIECE(^PRCP(445.3,ORDERDA,0),"^",2),0),"^",1)
+48 SET XMB="PRCP_NO_REFILL"
+49 SET XMDUZ="SUPPLY STATION INTERFACE"
+50 DO EN^XMB
+51 KILL ^TMP($JOB,"PRCPHL7")
End DoDot:2
End DoDot:1
GOTO Q
+52 ;
ERR ;
+1 NEW NUMBER,PRCPHLPO
+2 SET NUMBER=ERR
+3 SET PRCPHLPO("ORDER")=$PIECE($GET(^PRCP(445.3,ORDERDA,0)),"^",1)
+4 SET PRCPHLPO("SIPNAME")=""
IF $DATA(^PRCP(445,PRCPSECO))
SET PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSECO)
+5 SET PRCPHLPO("ITEM")=""
IF $DATA(PRCPITEM)
SET PRCPHLPO("ITEM")=PRCPITEM
+6 SET PRCPHLPO("NAME")=""
IF $DATA(PRCPITNM)
SET PRCPHLPO("NAME")=PRCPITNM
+7 SET PRCPHLPO("QTY")=""
IF $DATA(PRCPAMT)
SET PRCPHLPO("QTY")=PRCPAMT
+8 SET PRCPHLPO("LEFT")=""
IF $DATA(PRCPLEFT)
SET PRCPHLPO("LEFT")=PRCPLEFT
+9 SET PRCPHLPO("TYPE")=""
IF $DATA(PRCPPOST)
SET PRCPHLPO("TYPE")=PRCPPOST
+10 DO ERR^PRCPHLM0(ERR,"PRCP_BAD_ORDER",PRCPSECO,.PRCPHLPO,PRCPHL7)
+11 SET PRCPDONE=1
+12 ;
Q IF LOCKORD
LOCK -^PRCP(445.3,ORDERDA)
DO CLEAR^PRCPULOC(445.3,ORDERDA_"-1",0)
+1 IF LOCKPRIM
LOCK -^PRCP(445,PRCPPRIM,1)
DO CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0)
+2 QUIT
