source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPL5.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PRCPWPL5 ;WISC/RFJ-whse post issue book (post end) ;13 Jan 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ENDPOST ; end of posting
8 K VALMBCK
9 ;
10 I $G(DRUGACCT) D EX^PSAGIP
11 W !!?4,"TOTAL LINE ITEMS POSTED : "_TOTLINES
12 ;
13 N %,ISMSFLAG,ITEMDA,LINEDA,PRCPDEV,PRCPFLAG,PRCPNAME,PRCPPOST,PRCPTRID,PRCPTRNO,PRCPUSER,QTYOUT,X,Y,ZTSK
14 ;
15 ; set for running balance report
16 S $P(^PRCS(410,PRCPDA,445),"^",3)=$P($G(^PRCS(410,PRCPDA,445)),"^",3)+TOTALSAL,$P(^PRCS(410,PRCPDA,4),"^",4)=DT,X=TOTALSAL
17 ; add/edit seller and edit buyer entries in file 410
18 I '$G(CANTEEN) D
19 . I $P($G(^PRCS(410,PRCPDA,4)),U,10)="" D IB^PRCS0B(PRCPPSTA_"^"_PRCPWSTA,PRCPPFCP_"^"_PRCPWFCP,PRCPDA,X_"^"_X) Q
20 . N A,B
21 . S A=^PRCS(410,PRCPDA,0),B=$P($G(^(3)),"^",11),A=$P($$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),"^",7)
22 . S PRCPRBSL=PRCPWSTA_"^"_PRCPWFCP_"^"_"A"_"^"_"^"_DT_"^"_-TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
23 . S $P(PRCPRBSL,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
24 . D A410^PRC0F(.PRCPXX,PRCPRBSL)
25 . S PRCPRBBY=PRCPPSTA_"^"_PRCPPFCP_"^"_"A"_"^"_"^"_DT_"^"_TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
26 . S $P(PRCPRBBY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
27 . D A410^PRC0F(.PRCPXX,PRCPRBBY)
28 . K PRCPRBSL,PRCPRBBY,PRCPXX
29 ;
30 ; make issue book a final
31 I '$D(PRCPFINL) W ! S PRCPFINL=$S($$FINALASK^PRCPWPL2=1:1,1:0)
32 I $G(PRCPFINL) D FINAL
33 ;
34 D UNLOCK^PRCPWPL3
35 ;
36 I TOTLINES=0 Q:$G(PRCPFINL) S VALMSG="NO LINE ITEMS TO POST",VALMBCK="R" Q
37 ;
38 ; print picking ticket
39 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)
40 S PRCPDEV=$P($G(^PRCP(445,PRCPINPT,"DEV")),"^")
41 I PRCPDEV'="" S ZTIO=PRCPDEV D QUEUE W !!,"Picking Ticket Queued on printer ",PRCPDEV G CODESHTS
42DEVICE ;
43 S %ZIS("A")="PRINT PICKING TICKET OF DEVICE: ",%ZIS("B")="",%ZIS="Q" W ! D ^%ZIS K %ZIS G:POP CODESHTS
44 I $D(IO("Q")) D QUEUE G CODESHTS
45 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
46 D DQ^PRCPRPIT,^%ZISC
47 ;
48CODESHTS ; create code sheets
49 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."
50 W ! D DISPLAY^PRCPUX2(5,75,.X)
51 I '$G(CANTEEN) D IV^PRCPSFIV(PRCP("I"),"R"_PRCPWORD,PRCPIBNM,"","")
52 I $G(CANTEEN) D SV^PRCPSFSV(PRCP("I"),"R"_PRCPWORD,"","")
53 S ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
54 I ISMSFLAG'=2 D DQ^PRCPSLOI(PRCPIBNM,"R"_PRCPWORD)
55 I ISMSFLAG=2 D DQ^PRCPSMPI(PRCPIBNM,"R"_PRCPWORD)
56 D R^PRCPUREP
57 Q
58 ;
59 ;
60FINAL ; make issue book a final
61 S $P(^PRCS(410,PRCPDA,9),"^",3)=DT,$P(^PRCS(410,PRCPDA,10),"^",4)=$O(^PRCD(442.3,"C",40,0))
62 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
63 . I $D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYOUT)
64 . I $G(PRCPFPRI) D KILLTRAN^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA)
65 ;
66 ; remove 2237 from request worksheet file
67 N DA,DIC,DIK
68 S DIK="^PRC(443,",DA=PRCPDA D ^DIK
69 W !!,"ISSUE BOOK IS NOW FINAL !"
70 Q
71 ;
72 ;
73QUEUE ; queue to print picking ticket
74 S ZTDESC="Picking Ticket (Whse to Primary)",ZTRTN="DQ^PRCPRPIT",ZTDTH=$H
75 S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
76 D ^%ZTLOAD
77 Q
Note: See TracBrowser for help on using the repository browser.