- 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 Feb 18, 2025@23:40:18 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
