PRCPOPP ;WISC/RFJ-post distribution order; ; 8/4/99 1:05pm
V ;;5.1;IFCAP;**1,41**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
PRCPSS(ORDERDA,PRCPSECO,PRCPPRIM,PRCPSS) ; entry point for supply station
; ORDERDA order to be posted
; PRCPSECO secondary inventory point
; PRCPPRIM primary inventory point
; PRCPSS flag to designate supply station posting (value = 1)
G PRCPSS0
;
POST ; post order
; orderda=order number
S VALMBCK="R"
N PRCPSS S PRCPSS=0 ; posting is done at GIP
;
PRCPSS0 N %,CONVFACT,DATA,ITEMDA,ITEMDATA,ORDRDATA,PRCPFLAG,PRCPID,PRCPOH,PRCPOPP,PRCPPORD,PRCPPTDA,PRCPSORD,QTYDUE,QUANTITY,TOTCOST,UNITCOST,XORDERDA,XDT
;
; Check for old orders
S XORDERDA=0 F S XORDERDA=$O(^PRCP(445.3,XORDERDA)) Q:'XORDERDA Q:XORDERDA]"A" D
. S XDT=$P($G(^PRCP(445.3,XORDERDA,0)),"^",9)
. Q:'XDT
. I XDT+2<DT D DELORDER^PRCPOPD(XORDERDA)
. Q
;
I PRCPSS G PRCPSS1 ; checks not valid for supply station posting
;
W !!,"CHECKING ITEMS ON ORDER..."
S (ITEMDA,PRCPFLAG)=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S QUANTITY=$P($G(^(ITEMDA,0)),"^",2) I QUANTITY D I PRCPFLAG Q
. I $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'="" S PRCPFLAG=1 Q
I PRCPFLAG S VALMSG="ORDER CANNOT BE POSTED - FIX ALL ERRORS FIRST" D CHECKORD^PRCPOPER Q
W " NO ERRORS FOUND !",!
;
I $P($G(^PRCP(445.3,ORDERDA,0)),"^",7)="" D Q:$G(PRCPFLAG)
. S XP="Do you want to print the picking ticket before posting",XH="Enter YES to print the picking ticket, NO to skip printing it, or ^ to exit."
. S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
. I %'=1 Q
. D PICKLM^PRCPOPT
;
S XP="Are you sure you want to POST this order to "_$$INVNAME^PRCPUX1(+$P($G(^PRCP(445.3,+ORDERDA,0)),"^",3)),XH="Enter 'YES' to start posting the order to the secondary inventory point",XH(1)="Enter 'NO' or '^' to exit."
W ! I $$YN^PRCPUYN(1)'=1 Q
;
L +^PRCP(445,PRCPPRIM,1):5
I '$T D SHOWWHO^PRCPULOC(445,PRCPPRIM_"-1",0) Q
L +^PRCP(445,PRCPSECO,1):5 I '$T D Q
. L -^PRCP(445,PRCPPRIM,1)
. D SHOWWHO^PRCPULOC(445,PRCPSECO_"-1",0)
D ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"Distribution Order Processing")
D ADD^PRCPULOC(445,PRCPSECO_"-1",0,"Distribution Order Processing")
;
W !,"POSTING DISTRIBUTION ORDER ..."
;
; if patient is on order, add entry
PRCPSS1 ; use the same transaction register numbers fr the entire order
S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPPRIM)
S PRCPSORD=$$ORDERNO^PRCPUTRX(PRCPSECO)
;
I $P($G(^PRCP(445.3,ORDERDA,2)),"^") S DATA=^(2) D
. S PRCPPTDA=+$P(DATA,"^",3) I $D(^PRCP(446.1,PRCPPTDA,0)) Q
. S PRCPPTDA=$$PATIENT^PRCPUPAT(+$P(DATA,"^"),+$P(DATA,"^",2))
. I 'PRCPPTDA Q
. S $P(^PRCP(445.3,ORDERDA,2),"^",3)=PRCPPTDA
. S $P(^PRCP(446.1,PRCPPTDA,0),"^",6)=PRCPSECO
;
; store case carts and instrument kits in
; ^tmp($j,"prcpopccik",itemda)=qty for cc/ik item posting
K ^TMP($J,"PRCPOPCCIK")
;
; post order
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S ORDRDATA=$G(^(ITEMDA,0)) D
. S (QTYDUE,QUANTITY)=$P(ORDRDATA,"^",2)
. S PRCPOH=$P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)
. I PRCPOH+0=0 S PRCPOH=0
. I QUANTITY>PRCPOH S QUANTITY=PRCPOH
. I PRCPOH<0 S QUANTITY=0
. I PRCPSS S QUANTITY=$P(ORDRDATA,"^",7) ; use qty that was stocked
. ;
. ; if case cart or instrument kit, set tmp global
. I $D(^PRCP(445.7,ITEMDA,0))!($D(^PRCP(445.8,ITEMDA,0))) S:QUANTITY>0 ^TMP($J,"PRCPOPCCIK",ITEMDA)=QUANTITY Q
. ;
. S ITEMDATA=^PRCP(445,PRCPPRIM,1,ITEMDA,0)
. S UNITCOST=+$P(ITEMDATA,"^",22) I 'UNITCOST S UNITCOST=+$P(ITEMDATA,"^",15)
. I 'UNITCOST S UNITCOST=+$P(ORDRDATA,"^",3)
. S TOTCOST=$J(QUANTITY*UNITCOST,0,2)
. ;
. ;
. I QTYDUE'=0 D
. . I 'PRCPSS!(PRCPSS&$D(^PRCP(445,PRCPPRIM,1,ITEMDA))) D
. . . ; sell from primary
. . . K PRCPOPP
. . . S PRCPOPP("QTY")=-QUANTITY,PRCPOPP("DUEOUT")=-QTYDUE,PRCPOPP("INVVAL")=-TOTCOST,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
. . . D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
. . ;
. . I 'PRCPSS!(PRCPSS&$D(^PRCP(445,PRCPSECO,1,ITEMDA))) D
. . . ; receipt in secondary
. . . S CONVFACT=$P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
. . . K PRCPOPP
. . . S PRCPOPP("QTY")=QUANTITY*CONVFACT,PRCPOPP("DUEIN")=-QTYDUE*CONVFACT,PRCPOPP("INVVAL")=TOTCOST,PRCPOPP("OTHERPT")=PRCPPRIM
. . . ; if patient, distribute from secondary to patient
. . . I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=PRCPPTDA
. . . D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
. . . Q
. ;
. ; Set quantity posted into item multiple
. I 'PRCPSS S $P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",7)=QUANTITY
;
; Set up posted status
S $P(^PRCP(445.3,ORDERDA,0),"^",6)="P",$P(^(0),"^",9)=DT
;
; if an item is a cc or ik
I $O(^TMP($J,"PRCPOPCCIK",0)) D
. ; if interactive, display screen to post items in cc and iks
. I 'PRCPSS D EN^VALM("PRCP DIST ORDER CC/IK POSTING")
. I PRCPSS D ; mark amount rec'd as 0, so user gets message
. . N PRCPAMT
. . S DIE="^PRCP(445.3,"_ORDERDA_",1,"
. . S DA=PRCPITEM
. . S PRCPAMT="@" ; delete entry to invoke bulletin to user
. . S DR="6///^S X=PRCPAMT"
. . D ^DIE K DIE
. . Q
. Q
;
I 'PRCPSS D
. D CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0),CLEAR^PRCPULOC(445,PRCPSECO_"-1",0)
. L -^PRCP(445,PRCPPRIM,1),-^PRCP(445,PRCPSECO,1)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPP 5583 printed Sep 23, 2025@19:50:19 Page 2
PRCPOPP ;WISC/RFJ-post distribution order; ; 8/4/99 1:05pm
V ;;5.1;IFCAP;**1,41**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
PRCPSS(ORDERDA,PRCPSECO,PRCPPRIM,PRCPSS) ; entry point for supply station
+1 ; ORDERDA order to be posted
+2 ; PRCPSECO secondary inventory point
+3 ; PRCPPRIM primary inventory point
+4 ; PRCPSS flag to designate supply station posting (value = 1)
+5 GOTO PRCPSS0
+6 ;
POST ; post order
+1 ; orderda=order number
+2 SET VALMBCK="R"
+3 ; posting is done at GIP
NEW PRCPSS
SET PRCPSS=0
+4 ;
PRCPSS0 NEW %,CONVFACT,DATA,ITEMDA,ITEMDATA,ORDRDATA,PRCPFLAG,PRCPID,PRCPOH,PRCPOPP,PRCPPORD,PRCPPTDA,PRCPSORD,QTYDUE,QUANTITY,TOTCOST,UNITCOST,XORDERDA,XDT
+1 ;
+2 ; Check for old orders
+3 SET XORDERDA=0
FOR
SET XORDERDA=$ORDER(^PRCP(445.3,XORDERDA))
if 'XORDERDA
QUIT
if XORDERDA]"A"
QUIT
Begin DoDot:1
+4 SET XDT=$PIECE($GET(^PRCP(445.3,XORDERDA,0)),"^",9)
+5 if 'XDT
QUIT
+6 IF XDT+2<DT
DO DELORDER^PRCPOPD(XORDERDA)
+7 QUIT
End DoDot:1
+8 ;
+9 ; checks not valid for supply station posting
IF PRCPSS
GOTO PRCPSS1
+10 ;
+11 WRITE !!,"CHECKING ITEMS ON ORDER..."
+12 SET (ITEMDA,PRCPFLAG)=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
if 'ITEMDA
QUIT
SET QUANTITY=$PIECE($GET(^(ITEMDA,0)),"^",2)
IF QUANTITY
Begin DoDot:1
+13 IF $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'=""
SET PRCPFLAG=1
QUIT
End DoDot:1
IF PRCPFLAG
QUIT
+14 IF PRCPFLAG
SET VALMSG="ORDER CANNOT BE POSTED - FIX ALL ERRORS FIRST"
DO CHECKORD^PRCPOPER
QUIT
+15 WRITE " NO ERRORS FOUND !",!
+16 ;
+17 IF $PIECE($GET(^PRCP(445.3,ORDERDA,0)),"^",7)=""
Begin DoDot:1
+18 SET XP="Do you want to print the picking ticket before posting"
SET XH="Enter YES to print the picking ticket, NO to skip printing it, or ^ to exit."
+19 SET %=$$YN^PRCPUYN(1)
IF %<1
SET PRCPFLAG=1
QUIT
+20 IF %'=1
QUIT
+21 DO PICKLM^PRCPOPT
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+22 ;
+23 SET XP="Are you sure you want to POST this order to "_$$INVNAME^PRCPUX1(+$PIECE($GET(^PRCP(445.3,+ORDERDA,0)),"^",3))
SET XH="Enter 'YES' to start posting the order to the secondary inventory point"
SET XH(1)="Enter 'NO' or '^' to exit."
+24 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+25 ;
+26 LOCK +^PRCP(445,PRCPPRIM,1):5
+27 IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPPRIM_"-1",0)
QUIT
+28 LOCK +^PRCP(445,PRCPSECO,1):5
IF '$TEST
Begin DoDot:1
+29 LOCK -^PRCP(445,PRCPPRIM,1)
+30 DO SHOWWHO^PRCPULOC(445,PRCPSECO_"-1",0)
End DoDot:1
QUIT
+31 DO ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"Distribution Order Processing")
+32 DO ADD^PRCPULOC(445,PRCPSECO_"-1",0,"Distribution Order Processing")
+33 ;
+34 WRITE !,"POSTING DISTRIBUTION ORDER ..."
+35 ;
+36 ; if patient is on order, add entry
PRCPSS1 ; use the same transaction register numbers fr the entire order
+1 SET PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPPRIM)
+2 SET PRCPSORD=$$ORDERNO^PRCPUTRX(PRCPSECO)
+3 ;
+4 IF $PIECE($GET(^PRCP(445.3,ORDERDA,2)),"^")
SET DATA=^(2)
Begin DoDot:1
+5 SET PRCPPTDA=+$PIECE(DATA,"^",3)
IF $DATA(^PRCP(446.1,PRCPPTDA,0))
QUIT
+6 SET PRCPPTDA=$$PATIENT^PRCPUPAT(+$PIECE(DATA,"^"),+$PIECE(DATA,"^",2))
+7 IF 'PRCPPTDA
QUIT
+8 SET $PIECE(^PRCP(445.3,ORDERDA,2),"^",3)=PRCPPTDA
+9 SET $PIECE(^PRCP(446.1,PRCPPTDA,0),"^",6)=PRCPSECO
End DoDot:1
+10 ;
+11 ; store case carts and instrument kits in
+12 ; ^tmp($j,"prcpopccik",itemda)=qty for cc/ik item posting
+13 KILL ^TMP($JOB,"PRCPOPCCIK")
+14 ;
+15 ; post order
+16 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
if 'ITEMDA
QUIT
SET ORDRDATA=$GET(^(ITEMDA,0))
Begin DoDot:1
+17 SET (QTYDUE,QUANTITY)=$PIECE(ORDRDATA,"^",2)
+18 SET PRCPOH=$PIECE($GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)
+19 IF PRCPOH+0=0
SET PRCPOH=0
+20 IF QUANTITY>PRCPOH
SET QUANTITY=PRCPOH
+21 IF PRCPOH<0
SET QUANTITY=0
+22 ; use qty that was stocked
IF PRCPSS
SET QUANTITY=$PIECE(ORDRDATA,"^",7)
+23 ;
+24 ; if case cart or instrument kit, set tmp global
+25 IF $DATA(^PRCP(445.7,ITEMDA,0))!($DATA(^PRCP(445.8,ITEMDA,0)))
if QUANTITY>0
SET ^TMP($JOB,"PRCPOPCCIK",ITEMDA)=QUANTITY
QUIT
+26 ;
+27 SET ITEMDATA=^PRCP(445,PRCPPRIM,1,ITEMDA,0)
+28 SET UNITCOST=+$PIECE(ITEMDATA,"^",22)
IF 'UNITCOST
SET UNITCOST=+$PIECE(ITEMDATA,"^",15)
+29 IF 'UNITCOST
SET UNITCOST=+$PIECE(ORDRDATA,"^",3)
+30 SET TOTCOST=$JUSTIFY(QUANTITY*UNITCOST,0,2)
+31 ;
+32 ;
+33 IF QTYDUE'=0
Begin DoDot:2
+34 IF 'PRCPSS!(PRCPSS&$DATA(^PRCP(445,PRCPPRIM,1,ITEMDA)))
Begin DoDot:3
+35 ; sell from primary
+36 KILL PRCPOPP
+37 SET PRCPOPP("QTY")=-QUANTITY
SET PRCPOPP("DUEOUT")=-QTYDUE
SET PRCPOPP("INVVAL")=-TOTCOST
SET PRCPOPP("OTHERPT")=PRCPSECO
SET PRCPOPP("ORDERDA")=ORDERDA
+38 DO SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
End DoDot:3
+39 ;
+40 IF 'PRCPSS!(PRCPSS&$DATA(^PRCP(445,PRCPSECO,1,ITEMDA)))
Begin DoDot:3
+41 ; receipt in secondary
+42 SET CONVFACT=$PIECE($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
+43 KILL PRCPOPP
+44 SET PRCPOPP("QTY")=QUANTITY*CONVFACT
SET PRCPOPP("DUEIN")=-QTYDUE*CONVFACT
SET PRCPOPP("INVVAL")=TOTCOST
SET PRCPOPP("OTHERPT")=PRCPPRIM
+45 ; if patient, distribute from secondary to patient
+46 IF $GET(PRCPPTDA)
SET PRCPOPP("PRCPPTDA")=PRCPPTDA
+47 DO RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
+48 QUIT
End DoDot:3
End DoDot:2
+49 ;
+50 ; Set quantity posted into item multiple
+51 IF 'PRCPSS
SET $PIECE(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",7)=QUANTITY
End DoDot:1
+52 ;
+53 ; Set up posted status
+54 SET $PIECE(^PRCP(445.3,ORDERDA,0),"^",6)="P"
SET $PIECE(^(0),"^",9)=DT
+55 ;
+56 ; if an item is a cc or ik
+57 IF $ORDER(^TMP($JOB,"PRCPOPCCIK",0))
Begin DoDot:1
+58 ; if interactive, display screen to post items in cc and iks
+59 IF 'PRCPSS
DO EN^VALM("PRCP DIST ORDER CC/IK POSTING")
+60 ; mark amount rec'd as 0, so user gets message
IF PRCPSS
Begin DoDot:2
+61 NEW PRCPAMT
+62 SET DIE="^PRCP(445.3,"_ORDERDA_",1,"
+63 SET DA=PRCPITEM
+64 ; delete entry to invoke bulletin to user
SET PRCPAMT="@"
+65 SET DR="6///^S X=PRCPAMT"
+66 DO ^DIE
KILL DIE
+67 QUIT
End DoDot:2
+68 QUIT
End DoDot:1
+69 ;
+70 IF 'PRCPSS
Begin DoDot:1
+71 DO CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0)
DO CLEAR^PRCPULOC(445,PRCPSECO_"-1",0)
+72 LOCK -^PRCP(445,PRCPPRIM,1),-^PRCP(445,PRCPSECO,1)
End DoDot:1
+73 ;
+74 QUIT
