source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHREC7.m@ 623

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

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1PRCHREC7 ;WISC/RWS-CODE SHEET GENERATOR - DEPOT TRANSACTIONS ;10-24-91/10:10
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5LOG ;CREATE LOG CODE SHEETS
6 N D0,I D:'$D(PRCHDEP) VOUCHER Q:'PRCHDEP
7 S PRCFA("DEL")=$P(^PRC(442,PRCHPO,0),U,10),PRCFA("LBN")=$P(^(0),U,1),PRCFA("ISSUE")=$P(^(2,+PRCHRIT,0),U,3),PRCFA("MULT")=$P(^(0),U,12),Y=$P(^(0),U,13),PRCFA("NSN")=$E(Y,6,7)_$E(Y,9,11)_$E(Y,13,17),PRCFA("FSC")=Y
8 S Y=$P(PRCHDEP,U,2),PRCFA("LDATE")=$E(Y,4,7)_$E(Y,2,3),PRCFA("SITE")=$S($E(PRCHDEP)=2:"79A",$E(PRCHDEP)=3:"794",1:"793"),PRCFA("TTLEN")=80
9 S PRCHLOG="",PRCFA("SYS")="LOG",PRCFA("TT")=$S($D(PRCHNRQ):"431",1:"434"),PRCFA("REF")=$E($P($P(^PRC(442,PRCHPO,0),U,1),"-",2),2,6),PRCF("X")="P",PRCFA("EDIT")="[PRCHL"_PRCFA("TT")_"]"
10 D:PRCHRTP PRINT D ^PRCFSITE G:'% OUT D NEWCS^PRCFAC G:'$D(DA) OUT S $P(^PRC(442,PRCHPO,2,+PRCHRIT,3,PRCHRDY,0),U,6)=DA,^PRC(442,PRCHPO,2,+PRCHRIT,3,"AB",DA,PRCHRDY)=""
11 S X1=+PRCHRIT_"^^"_PRCHRQ_U_"^^^"_PRCFA("DEL")_"^^"_PRCFA("NSN"),PRCFA("LBN")=PRCFA("LBN")_"."_$P(PRCHRIT,U,1)
12 S Z=$P(PRCHDEP,U,2)_U_"^^^^^^^^"_PRCFA("MULT")_"^^"_PRCHRAM_"^^^"_PRCFA("SITE")
13 S ^PRCF(423,DA,300)=X1,^(304)=Z,$P(^(301),U,15)=PRCFA("REF"),$P(^(301),U,38)=+PRCHDEP
14 ;
15VOU S DIE="^PRCF(423,",DR="[PRCH-REC7 LOG 431/434]" D ^DIE,^PRCFACX1
16 ;
17OUT K %,B,D,D0,DA,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DQ,DR,J,K,M,N,PRCFA,PRCFASYS,Q,Q1,S,X,XL1,Y,Z
18 Q
19 ;
20VOUCHER ;SELECT VOUCHER NUMBER
21 ;
22Q1 R !!,"LOG DATE: TODAY//",X:DTIME G:X="^"!'$T OUT S %DT="EX",%DT(0)="-NOW" S:X="" X="TODAY" D ^%DT K %DT G:Y<0 Q1 S PRCFA("LDATE")=Y
23 ;
24Q2 R !!,"DEPOT: HINES//",X:DTIME G:X="^"!'$T OUT S PRCHDEP=$S("793HINES"[X:"4","794SOMMERVILLE"[X:"2","79ABELL"[X:"3",1:""),X=PRCHDEP G:'PRCHDEP Q2 W " ("_$S(X=4:"HINES)",X=3:"BELL)",1:"SOMMERVILLE)")
25 S X=PRC("SITE")_"-"_PRC("FY")_"-"_"DVCODE"_+PRCHDEP,DIC="^PRCS(410.1,",DIC(0)="Z" I '$D(^PRCS("410.1","B",X)) S DIC("DR")="1////1" D FILE^DICN
26 D ^DIC S Y(1)=$P(Y(0),U,2),PRCHDEP=PRCHDEP_$E("000",$L(Y(1)),3)_Y(1)_U_PRCFA("LDATE"),DIE=DIC,DA=+Y,DR="1////"_(Y(1)+1)_";2///T" D ^DIE K DIC,X,Y
27 W !!,"This session has been assigned Depot Voucher Number ",+PRCHDEP
28 Q
29 ;
30PRINT W !,"UNIT OF PRCH: ",$P($G(^PRCD(420.5,PRCFA("ISSUE"),0)),U,1)," QTY ORDERED: ",PRCHRQ1," PREVIOUSLY RECEIVED: ",PRCHRQ2,!?3,"QTY BEING RECEIVED: ",PRCHRQ,!
31 Q
32 ;
33EXP I PRCFA("FSC")?1"89".E,X>$P(PRCHDEP,U,2) K X Q
34 I PRCFA("FSC")?1"6505".E,Y<$P(PRCHDEP,U,2) K X
35 Q
Note: See TracBrowser for help on using the repository browser.