PRCPUTRX ;WISC/RFJ-transaction history file 445.2 sets ;07 Jul 92
V ;;5.1;IFCAP;**1,126**;Oct 20, 2000;Build 2
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ADDTRAN(INVPT,ITEMDA,TRANTYPE,ORDERNO,PRCPDATA) ; add transaction entry
;prcpdata nodes:
; date) = date of transaction (posted or issued, etc)
; (optional) if not set it uses current date
; qty) = quantity of transaction
; invval) = inventory value
; selval) = sales value
; avgunit) = average unit cost
; selunit) = selling unit cost
; pkg) = unit per issue / units
; (optional) set to current if not passed
; ref) = reference number
; 2237po) = 2237 or purchase order number
; issue) = issue/nonissue
; (optional) set to I for issuable, N for non
; otherpt) = other inventory point
; reason) = n:reason (if n=1 ask reason)
; reasoncode) = reason code (for whse other adjustments)
; recipient = who got the supply
; user = person who took the supply from the cabinet
;
; returns variable y = da of entry added
S Y=0
;
; inventory point is not keeping a detailed transaction reg.
I $P($G(^PRCP(445,+INVPT,0)),"^",6)'="Y" Q
;
N %,%DT,D,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,NOW,PRCPDR,PRCPPRIV,PRCPREAS,TRANDA,X
D NOW^%DTC S NOW=%
;
; set up all variables not defined
I '$G(PRCPDATA("DATE")) S PRCPDATA("DATE")=$E(NOW,1,7)
I '$D(PRCPDATA("PKG")) S PRCPDATA("PKG")=$$UNIT^PRCPUX1(INVPT,ITEMDA,"/")
F %="QTY","INVVAL","SELVAL" I '$G(PRCPDATA(%)) S PRCPDATA(%)=0
S %=$G(^PRCP(445,INVPT,1,ITEMDA,0))
I '$G(PRCPDATA("AVGUNIT")) D
. S PRCPDATA("AVGUNIT")=+$P(%,"^",22)
. I TRANTYPE="P",PRCPDATA("AVGUNIT")=0 S PRCPDATA("AVGUNIT")=+$P(%,"^",15)
S:'$G(PRCPDATA("SELUNIT")) PRCPDATA("SELUNIT")=+$P(%,"^",15)
F %="REF","2237PO","ISSUE","OTHERPT","REASON","RECIPIENT","USER" I '$D(PRCPDATA(%)) S PRCPDATA(%)=""
;
; add new transaction history entry
S DIC(0)="L",DLAYGO=445.2,DIC="^PRCP(445.2,",X=INVPT,PRCPPRIV=1
D FILE^DICN I Y<1 S Y=0 Q
S (TRANDA,DA)=+Y,DIE="^PRCP(445.2,"
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"))_";"
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")_";"
S DR=DR_"23////"_PRCPDATA("RECIPIENT")_";"
S DR=DR_"22////"_PRCPDATA("USER")_";"
; additional reason text (for asking in second call to die)
S PRCPDR="" I $D(PRCPDATA("REASONCODE")) S PRCPDR="9////"_$E(PRCPDATA("REASONCODE"),1,3)_";"
S PRCPDR=PRCPDR_"9.5//"_$S($P(PRCPDATA("REASON"),":"):"",1:"/")_"^S X=PRCPREAS",PRCPREAS=$E($P(PRCPDATA("REASON"),":",2,99),1,80)
L +^PRCP(445.2,TRANDA)
D ^DIE
S DR=PRCPDR
D ^DIE
L -^PRCP(445.2,TRANDA)
S Y=DA
Q
;
;
ORDERNO(INVPT) ; get next order number for inventory point
; returns orderno
S Y=0
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)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUTRX 3371 printed Oct 16, 2024@18:17:12 Page 2
PRCPUTRX ;WISC/RFJ-transaction history file 445.2 sets ;07 Jul 92
V ;;5.1;IFCAP;**1,126**;Oct 20, 2000;Build 2
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
ADDTRAN(INVPT,ITEMDA,TRANTYPE,ORDERNO,PRCPDATA) ; add transaction entry
+1 ;prcpdata nodes:
+2 ; date) = date of transaction (posted or issued, etc)
+3 ; (optional) if not set it uses current date
+4 ; qty) = quantity of transaction
+5 ; invval) = inventory value
+6 ; selval) = sales value
+7 ; avgunit) = average unit cost
+8 ; selunit) = selling unit cost
+9 ; pkg) = unit per issue / units
+10 ; (optional) set to current if not passed
+11 ; ref) = reference number
+12 ; 2237po) = 2237 or purchase order number
+13 ; issue) = issue/nonissue
+14 ; (optional) set to I for issuable, N for non
+15 ; otherpt) = other inventory point
+16 ; reason) = n:reason (if n=1 ask reason)
+17 ; reasoncode) = reason code (for whse other adjustments)
+18 ; recipient = who got the supply
+19 ; user = person who took the supply from the cabinet
+20 ;
+21 ; returns variable y = da of entry added
+22 SET Y=0
+23 ;
+24 ; inventory point is not keeping a detailed transaction reg.
+25 IF $PIECE($GET(^PRCP(445,+INVPT,0)),"^",6)'="Y"
QUIT
+26 ;
+27 NEW %,%DT,D,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,NOW,PRCPDR,PRCPPRIV,PRCPREAS,TRANDA,X
+28 DO NOW^%DTC
SET NOW=%
+29 ;
+30 ; set up all variables not defined
+31 IF '$GET(PRCPDATA("DATE"))
SET PRCPDATA("DATE")=$EXTRACT(NOW,1,7)
+32 IF '$DATA(PRCPDATA("PKG"))
SET PRCPDATA("PKG")=$$UNIT^PRCPUX1(INVPT,ITEMDA,"/")
+33 FOR %="QTY","INVVAL","SELVAL"
IF '$GET(PRCPDATA(%))
SET PRCPDATA(%)=0
+34 SET %=$GET(^PRCP(445,INVPT,1,ITEMDA,0))
+35 IF '$GET(PRCPDATA("AVGUNIT"))
Begin DoDot:1
+36 SET PRCPDATA("AVGUNIT")=+$PIECE(%,"^",22)
+37 IF TRANTYPE="P"
IF PRCPDATA("AVGUNIT")=0
SET PRCPDATA("AVGUNIT")=+$PIECE(%,"^",15)
End DoDot:1
+38 if '$GET(PRCPDATA("SELUNIT"))
SET PRCPDATA("SELUNIT")=+$PIECE(%,"^",15)
+39 FOR %="REF","2237PO","ISSUE","OTHERPT","REASON","RECIPIENT","USER"
IF '$DATA(PRCPDATA(%))
SET PRCPDATA(%)=""
+40 ;
+41 ; add new transaction history entry
+42 SET DIC(0)="L"
SET DLAYGO=445.2
SET DIC="^PRCP(445.2,"
SET X=INVPT
SET PRCPPRIV=1
+43 DO FILE^DICN
IF Y<1
SET Y=0
QUIT
+44 SET (TRANDA,DA)=+Y
SET DIE="^PRCP(445.2,"
+45 SET 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"))_";"
+46 SET 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")_";"
+47 SET DR=DR_"23////"_PRCPDATA("RECIPIENT")_";"
+48 SET DR=DR_"22////"_PRCPDATA("USER")_";"
+49 ; additional reason text (for asking in second call to die)
+50 SET PRCPDR=""
IF $DATA(PRCPDATA("REASONCODE"))
SET PRCPDR="9////"_$EXTRACT(PRCPDATA("REASONCODE"),1,3)_";"
+51 SET PRCPDR=PRCPDR_"9.5//"_$SELECT($PIECE(PRCPDATA("REASON"),":"):"",1:"/")_"^S X=PRCPREAS"
SET PRCPREAS=$EXTRACT($PIECE(PRCPDATA("REASON"),":",2,99),1,80)
+52 LOCK +^PRCP(445.2,TRANDA)
+53 DO ^DIE
+54 SET DR=PRCPDR
+55 DO ^DIE
+56 LOCK -^PRCP(445.2,TRANDA)
+57 SET Y=DA
+58 QUIT
+59 ;
+60 ;
ORDERNO(INVPT) ; get next order number for inventory point
+1 ; returns orderno
+2 SET Y=0
+3 IF $PIECE($GET(^PRCP(445,+INVPT,0)),"^",6)="Y"
LOCK +^PRCP(445.2,"ANXT",INVPT)
SET Y=$GET(^PRCP(445.2,"ANXT",INVPT))+1
if Y>9999999
SET Y=1
SET ^(INVPT)=Y
LOCK -^PRCP(445.2,"ANXT",INVPT)
+4 QUIT Y
