source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUTRX.m@ 1141

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1PRCPUTRX ;WISC/RFJ-transaction history file 445.2 sets ;07 Jul 92
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ADDTRAN(INVPT,ITEMDA,TRANTYPE,ORDERNO,PRCPDATA) ; add transaction entry
8 ;prcpdata nodes:
9 ; date) = date of transaction (posted or issued, etc)
10 ; (optional) if not set it uses current date
11 ; qty) = quantity of transaction
12 ; invval) = inventory value
13 ; selval) = sales value
14 ; avgunit) = average unit cost
15 ; selunit) = selling unit cost
16 ; pkg) = unit per issue / units
17 ; (optional) set to current if not passed
18 ; ref) = reference number
19 ; 2237po) = 2237 or purchase order number
20 ; issue) = issue/nonissue
21 ; (optional) set to I for issuable, N for non
22 ; otherpt) = other inventory point
23 ; reason) = n:reason (if n=1 ask reason)
24 ; reasoncode) = reason code (for whse other adjustments)
25 ; recipient = who got the supply
26 ; user = person who took the supply from the cabinet
27 ;
28 ; returns variable y = da of entry added
29 S Y=0
30 ;
31 ; inventory point is not keeping a detailed transaction reg.
32 I $P($G(^PRCP(445,+INVPT,0)),"^",6)'="Y" Q
33 ;
34 N %,%DT,D,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,NOW,PRCPDR,PRCPPRIV,PRCPREAS,TRANDA,X
35 D NOW^%DTC S NOW=%
36 ;
37 ; set up all variables not defined
38 I '$G(PRCPDATA("DATE")) S PRCPDATA("DATE")=$E(NOW,1,7)
39 I '$D(PRCPDATA("PKG")) S PRCPDATA("PKG")=$$UNIT^PRCPUX1(INVPT,ITEMDA,"/")
40 F %="QTY","INVVAL","SELVAL" I '$G(PRCPDATA(%)) S PRCPDATA(%)=0
41 S %=$G(^PRCP(445,INVPT,1,ITEMDA,0))
42 S:'$G(PRCPDATA("AVGUNIT")) PRCPDATA("AVGUNIT")=+$P(%,"^",22)
43 S:'$G(PRCPDATA("SELUNIT")) PRCPDATA("SELUNIT")=+$P(%,"^",15)
44 F %="REF","2237PO","ISSUE","OTHERPT","REASON","RECIPIENT","USER" I '$D(PRCPDATA(%)) S PRCPDATA(%)=""
45 ;
46 ; add new transaction history entry
47 S DIC(0)="L",DLAYGO=445.2,DIC="^PRCP(445.2,",X=INVPT,PRCPPRIV=1
48 D FILE^DICN I Y<1 S Y=0 Q
49 S (TRANDA,DA)=+Y,DIE="^PRCP(445.2,"
50 S DR="1///"_TRANTYPE_ORDERNO_";2///"_PRCPDATA("DATE")_";2.5///"_NOW_";3///"_TRANTYPE_";4////"_ITEMDA_";5////"_PRCPDATA("PKG")_";6////"_PRCPDATA("QTY")_";7////"_(+PRCPDATA("AVGUNIT"))_";8////"_(+PRCPDATA("SELUNIT"))_";"
51 S DR=DR_"6.1////"_(+PRCPDATA("INVVAL"))_";6.2////"_(+PRCPDATA("SELVAL"))_";8.5////"_DUZ_";10////"_PRCPDATA("ISSUE")_";13////"_PRCPDATA("REF")_";14////"_PRCPDATA("OTHERPT")_";410////"_PRCPDATA("2237PO")_";"
52 S DR=DR_"23////"_PRCPDATA("RECIPIENT")_";"
53 S DR=DR_"22////"_PRCPDATA("USER")_";"
54 ; additional reason text (for asking in second call to die)
55 S PRCPDR="" I $D(PRCPDATA("REASONCODE")) S PRCPDR="9////"_$E(PRCPDATA("REASONCODE"),1,3)_";"
56 S PRCPDR=PRCPDR_"9.5//"_$S($P(PRCPDATA("REASON"),":"):"",1:"/")_"^S X=PRCPREAS",PRCPREAS=$E($P(PRCPDATA("REASON"),":",2,99),1,80)
57 L +^PRCP(445.2,TRANDA)
58 D ^DIE
59 S DR=PRCPDR
60 D ^DIE
61 L -^PRCP(445.2,TRANDA)
62 S Y=DA
63 Q
64 ;
65 ;
66ORDERNO(INVPT) ; get next order number for inventory point
67 ; returns orderno
68 S Y=0
69 I $P($G(^PRCP(445,+INVPT,0)),"^",6)="Y" L +^PRCP(445.2,"ANXT",INVPT) S Y=$G(^PRCP(445.2,"ANXT",INVPT))+1 S:Y>9999999 Y=1 S ^(INVPT)=Y L -^PRCP(445.2,"ANXT",INVPT)
70 Q Y
Note: See TracBrowser for help on using the repository browser.