Routine: PRCPOPP

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.

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPP   5583     printed  Mar 13, 2025@21:19:01                                                                                                                                                                                                     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

PRCPOPP.m