PRCPWPL5 ;WISC/RFJ-whse post issue book (post end) ;13 Jan 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ENDPOST ; end of posting
K VALMBCK
;
I $G(DRUGACCT) D EX^PSAGIP
W !!?4,"TOTAL LINE ITEMS POSTED : "_TOTLINES
;
N %,ISMSFLAG,ITEMDA,LINEDA,PRCPDEV,PRCPFLAG,PRCPNAME,PRCPPOST,PRCPTRID,PRCPTRNO,PRCPUSER,QTYOUT,X,Y,ZTSK
;
; set for running balance report
S $P(^PRCS(410,PRCPDA,445),"^",3)=$P($G(^PRCS(410,PRCPDA,445)),"^",3)+TOTALSAL,$P(^PRCS(410,PRCPDA,4),"^",4)=DT,X=TOTALSAL
; add/edit seller and edit buyer entries in file 410
I '$G(CANTEEN) D
. I $P($G(^PRCS(410,PRCPDA,4)),U,10)="" D IB^PRCS0B(PRCPPSTA_"^"_PRCPWSTA,PRCPPFCP_"^"_PRCPWFCP,PRCPDA,X_"^"_X) Q
. N A,B
. S A=^PRCS(410,PRCPDA,0),B=$P($G(^(3)),"^",11),A=$P($$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),"^",7)
. S PRCPRBSL=PRCPWSTA_"^"_PRCPWFCP_"^"_"A"_"^"_"^"_DT_"^"_-TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
. S $P(PRCPRBSL,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
. D A410^PRC0F(.PRCPXX,PRCPRBSL)
. S PRCPRBBY=PRCPPSTA_"^"_PRCPPFCP_"^"_"A"_"^"_"^"_DT_"^"_TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
. S $P(PRCPRBBY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
. D A410^PRC0F(.PRCPXX,PRCPRBBY)
. K PRCPRBSL,PRCPRBBY,PRCPXX
;
; make issue book a final
I '$D(PRCPFINL) W ! S PRCPFINL=$S($$FINALASK^PRCPWPL2=1:1,1:0)
I $G(PRCPFINL) D FINAL
;
D UNLOCK^PRCPWPL3
;
I TOTLINES=0 Q:$G(PRCPFINL) S VALMSG="NO LINE ITEMS TO POST",VALMBCK="R" Q
;
; print picking ticket
S Y=DT D DD^%DT S PRCPPOST=Y,PRCPTRNO=PRCPIBNM,PRCPTRID="R"_PRCPWORD,PRCPNAME=$P($$INVNAME^PRCPUX1(PRCPPRIM),"-",2,99),PRCPUSER=$$USER^PRCPUREP(DUZ)
S PRCPDEV=$P($G(^PRCP(445,PRCPINPT,"DEV")),"^")
I PRCPDEV'="" S ZTIO=PRCPDEV D QUEUE W !!,"Picking Ticket Queued on printer ",PRCPDEV G CODESHTS
DEVICE ;
S %ZIS("A")="PRINT PICKING TICKET OF DEVICE: ",%ZIS("B")="",%ZIS="Q" W ! D ^%ZIS K %ZIS G:POP CODESHTS
I $D(IO("Q")) D QUEUE G CODESHTS
I IO=IO(0) W !,"YOU CANNOT PRINT THE PICKING TICKET ON YOUR TERMINAL.",!,"IF YOU DO NOT WANT TO PRINT THE PICKING TICKET, PRESS '^'." G DEVICE
D DQ^PRCPRPIT,^%ZISC
;
CODESHTS ; create code sheets
K X S X(1)="The program will automatically create and transmit the code sheets to Austin. Please verify the accuracy of the data and submit adjustment code sheets if necessary."
W ! D DISPLAY^PRCPUX2(5,75,.X)
I '$G(CANTEEN) D IV^PRCPSFIV(PRCP("I"),"R"_PRCPWORD,PRCPIBNM,"","")
I $G(CANTEEN) D SV^PRCPSFSV(PRCP("I"),"R"_PRCPWORD,"","")
S ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
I ISMSFLAG'=2 D DQ^PRCPSLOI(PRCPIBNM,"R"_PRCPWORD)
I ISMSFLAG=2 D DQ^PRCPSMPI(PRCPIBNM,"R"_PRCPWORD)
D R^PRCPUREP
Q
;
;
FINAL ; make issue book a final
S $P(^PRCS(410,PRCPDA,9),"^",3)=DT,$P(^PRCS(410,PRCPDA,10),"^",4)=$O(^PRCD(442.3,"C",40,0))
S LINEDA=0 F S LINEDA=$O(^PRCS(410,PRCPDA,"IT",LINEDA)) Q:'LINEDA S ITEMDA=+$P(^(LINEDA,0),"^",5),QTYOUT=$P(^(0),"^",2)-$P(^(0),"^",12) I QTYOUT>0 D
. I $D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYOUT)
. I $G(PRCPFPRI) D KILLTRAN^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA)
;
; remove 2237 from request worksheet file
N DA,DIC,DIK
S DIK="^PRC(443,",DA=PRCPDA D ^DIK
W !!,"ISSUE BOOK IS NOW FINAL !"
Q
;
;
QUEUE ; queue to print picking ticket
S ZTDESC="Picking Ticket (Whse to Primary)",ZTRTN="DQ^PRCPRPIT",ZTDTH=$H
S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
D ^%ZTLOAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPL5 3514 printed Oct 16, 2024@18:17:28 Page 2
PRCPWPL5 ;WISC/RFJ-whse post issue book (post end) ;13 Jan 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ENDPOST ; end of posting
+1 KILL VALMBCK
+2 ;
+3 IF $GET(DRUGACCT)
DO EX^PSAGIP
+4 WRITE !!?4,"TOTAL LINE ITEMS POSTED : "_TOTLINES
+5 ;
+6 NEW %,ISMSFLAG,ITEMDA,LINEDA,PRCPDEV,PRCPFLAG,PRCPNAME,PRCPPOST,PRCPTRID,PRCPTRNO,PRCPUSER,QTYOUT,X,Y,ZTSK
+7 ;
+8 ; set for running balance report
+9 SET $PIECE(^PRCS(410,PRCPDA,445),"^",3)=$PIECE($GET(^PRCS(410,PRCPDA,445)),"^",3)+TOTALSAL
SET $PIECE(^PRCS(410,PRCPDA,4),"^",4)=DT
SET X=TOTALSAL
+10 ; add/edit seller and edit buyer entries in file 410
+11 IF '$GET(CANTEEN)
Begin DoDot:1
+12 IF $PIECE($GET(^PRCS(410,PRCPDA,4)),U,10)=""
DO IB^PRCS0B(PRCPPSTA_"^"_PRCPWSTA,PRCPPFCP_"^"_PRCPWFCP,PRCPDA,X_"^"_X)
QUIT
+13 NEW A,B
+14 SET A=^PRCS(410,PRCPDA,0)
SET B=$PIECE($GET(^(3)),"^",11)
SET A=$PIECE($$QTRDATE^PRC0D($PIECE(A,"-",2),$PIECE(A,"-",3)),"^",7)
+15 SET PRCPRBSL=PRCPWSTA_"^"_PRCPWFCP_"^"_"A"_"^"_"^"_DT_"^"_-TOTALSAL_"^"_$PIECE(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
+16 SET $PIECE(PRCPRBSL,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
+17 DO A410^PRC0F(.PRCPXX,PRCPRBSL)
+18 SET PRCPRBBY=PRCPPSTA_"^"_PRCPPFCP_"^"_"A"_"^"_"^"_DT_"^"_TOTALSAL_"^"_$PIECE(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
+19 SET $PIECE(PRCPRBBY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
+20 DO A410^PRC0F(.PRCPXX,PRCPRBBY)
+21 KILL PRCPRBSL,PRCPRBBY,PRCPXX
End DoDot:1
+22 ;
+23 ; make issue book a final
+24 IF '$DATA(PRCPFINL)
WRITE !
SET PRCPFINL=$SELECT($$FINALASK^PRCPWPL2=1:1,1:0)
+25 IF $GET(PRCPFINL)
DO FINAL
+26 ;
+27 DO UNLOCK^PRCPWPL3
+28 ;
+29 IF TOTLINES=0
if $GET(PRCPFINL)
QUIT
SET VALMSG="NO LINE ITEMS TO POST"
SET VALMBCK="R"
QUIT
+30 ;
+31 ; print picking ticket
+32 SET Y=DT
DO DD^%DT
SET PRCPPOST=Y
SET PRCPTRNO=PRCPIBNM
SET PRCPTRID="R"_PRCPWORD
SET PRCPNAME=$PIECE($$INVNAME^PRCPUX1(PRCPPRIM),"-",2,99)
SET PRCPUSER=$$USER^PRCPUREP(DUZ)
+33 SET PRCPDEV=$PIECE($GET(^PRCP(445,PRCPINPT,"DEV")),"^")
+34 IF PRCPDEV'=""
SET ZTIO=PRCPDEV
DO QUEUE
WRITE !!,"Picking Ticket Queued on printer ",PRCPDEV
GOTO CODESHTS
DEVICE ;
+1 SET %ZIS("A")="PRINT PICKING TICKET OF DEVICE: "
SET %ZIS("B")=""
SET %ZIS="Q"
WRITE !
DO ^%ZIS
KILL %ZIS
if POP
GOTO CODESHTS
+2 IF $DATA(IO("Q"))
DO QUEUE
GOTO CODESHTS
+3 IF IO=IO(0)
WRITE !,"YOU CANNOT PRINT THE PICKING TICKET ON YOUR TERMINAL.",!,"IF YOU DO NOT WANT TO PRINT THE PICKING TICKET, PRESS '^'."
GOTO DEVICE
+4 DO DQ^PRCPRPIT
DO ^%ZISC
+5 ;
CODESHTS ; create code sheets
+1 KILL X
SET X(1)="The program will automatically create and transmit the code sheets to Austin. Please verify the accuracy of the data and submit adjustment code sheets if necessary."
+2 WRITE !
DO DISPLAY^PRCPUX2(5,75,.X)
+3 IF '$GET(CANTEEN)
DO IV^PRCPSFIV(PRCP("I"),"R"_PRCPWORD,PRCPIBNM,"","")
+4 IF $GET(CANTEEN)
DO SV^PRCPSFSV(PRCP("I"),"R"_PRCPWORD,"","")
+5 SET ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
+6 IF ISMSFLAG'=2
DO DQ^PRCPSLOI(PRCPIBNM,"R"_PRCPWORD)
+7 IF ISMSFLAG=2
DO DQ^PRCPSMPI(PRCPIBNM,"R"_PRCPWORD)
+8 DO R^PRCPUREP
+9 QUIT
+10 ;
+11 ;
FINAL ; make issue book a final
+1 SET $PIECE(^PRCS(410,PRCPDA,9),"^",3)=DT
SET $PIECE(^PRCS(410,PRCPDA,10),"^",4)=$ORDER(^PRCD(442.3,"C",40,0))
+2 SET LINEDA=0
FOR
SET LINEDA=$ORDER(^PRCS(410,PRCPDA,"IT",LINEDA))
if 'LINEDA
QUIT
SET ITEMDA=+$PIECE(^(LINEDA,0),"^",5)
SET QTYOUT=$PIECE(^(0),"^",2)-$PIECE(^(0),"^",12)
IF QTYOUT>0
Begin DoDot:1
+3 IF $DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
DO SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYOUT)
+4 IF $GET(PRCPFPRI)
DO KILLTRAN^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA)
End DoDot:1
+5 ;
+6 ; remove 2237 from request worksheet file
+7 NEW DA,DIC,DIK
+8 SET DIK="^PRC(443,"
SET DA=PRCPDA
DO ^DIK
+9 WRITE !!,"ISSUE BOOK IS NOW FINAL !"
+10 QUIT
+11 ;
+12 ;
QUEUE ; queue to print picking ticket
+1 SET ZTDESC="Picking Ticket (Whse to Primary)"
SET ZTRTN="DQ^PRCPRPIT"
SET ZTDTH=$HOROLOG
+2 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ZTREQ")="@"
+3 DO ^%ZTLOAD
+4 QUIT
