- 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 Feb 18, 2025@23:42:50 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