PRCPEIL0 ;WISC/RFJ-edit inventory items (build arrays) ; 9/20/06 11:02am
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
ISSUNITS ; build issue units array
S LINE=9,COLUMN=1,CLREND=39
D SET("Issue Units ",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("Unit per Issue: "_$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),LINE+1,COLUMN,CLREND)
I PRCPTYPE="P" D SET("Issue Multiple",LINE+2,COLUMN,CLREND,16)
I PRCPTYPE="P" D SET("Min Issue Qty ",LINE+3,COLUMN,CLREND,16.5)
Q
;
;
COSTS ; build costs array
S LINE=16,COLUMN=40,CLREND=80
D SET("Costing Data",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("Last Cost ",LINE+1,COLUMN,CLREND,4.7)
D SET("Average Cost",LINE+2,COLUMN,CLREND,4.8)
D SET("Total Value ",LINE+3,COLUMN,CLREND,4.81)
Q
;
;
LEVELS ; build levels array
S LINE=9,COLUMN=40,CLREND=80
D SET("Levels ",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("Norm Stock Level",LINE+1,COLUMN,CLREND,9)
D SET("Emer Stock Level",LINE+2,COLUMN,CLREND,11)
D SET("Temp Stock Level",LINE+3,COLUMN,CLREND,9.5)
D SET("Delete Temp SL ",LINE+4,COLUMN,CLREND,9.6)
D SET("Stand Reord Pt ",LINE+5,COLUMN,CLREND,10)
D SET("Option Reord Pt ",LINE+6,COLUMN,CLREND,10.3)
Q
;
;
QUANTITY ; build quantities array
S LINE=16,COLUMN=1,CLREND=39
D SET("Quantities ",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("On-hand ",LINE+1,COLUMN,CLREND,7)
D SET("Due-In ",LINE+2,COLUMN,CLREND,8.1)
D SET("Due-Out ",LINE+3,COLUMN,CLREND,8.6)
D SET($S(PRCPTYPE="W":"Non-Issuable",1:""),LINE+4,COLUMN,CLREND,$S(PRCPTYPE="W":7.5,1:0))
D SET("",LINE+5,COLUMN,80)
Q
;
;
OUTSTRAN ; build outstanding transaction array
N D,PRCPDA
S LINE=22,COLUMN=1,CLREND=80
D SET("Due-Ins/Outstanding Transactions",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
S PRCPDA=0 F LINE=23:1:29 S PRCPDA=$O(^PRCP(445,PRCPINPT,1,ITEMDA,7,PRCPDA)) Q:'PRCPDA S X=$G(^(+PRCPDA,0)) D
. I X="" D SET("",LINE,COLUMN,CLREND) Q
. S D=$E($P($G(^PRCS(410,+$P(X,"^"),0)),"^")_$J("",34),1,34)_" Qty: "_$E($P(X,"^",2)_$J("",8),1,8)_" U/R: "_$E($$UNITVAL^PRCPUX1($P(X,"^",4),$P(X,"^",3),"/")_$J("",10),1,10)_" CF: "_$P(X,"^",5)
. D SET(D,LINE,COLUMN,CLREND)
F LINE=LINE:1:29 D SET("",LINE,COLUMN,CLREND)
S PRCPDA=$O(^PRCP(445,PRCPINPT,1,ITEMDA,7,PRCPDA))
D SET($S('PRCPDA:"",1:" . . . more . . . (only first 7 displayed)"),LINE+1,COLUMN,CLREND)
Q
;
;
SPECIAL ; build special parameter array
; subroutine modified to add On-Demand Items (PRC*5.1*98)
N PRCPONN S PRCPONN=""
S LINE=31,COLUMN=1,CLREND=39
D SET("Special Parameters",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("Kill When Zero ",LINE+1,COLUMN,CLREND,17)
D SET("",LINE+2,COLUMN,CLREND)
S X=""
I PRCPTYPE="W" S X="",%=0 F S %=$O(^PRCP(445,PRCPINPT,1,ITEMDA,4,%)) Q:'% S X=X_$S(X="":"",1:", ")_%
I PRCPTYPE'="W" D
. N X
. S X=$$GET1^DIQ(445.01,ITEMDA_","_PRCPINPT_",",.8,"E")
. I X']"" S X="NO"
. S PRCPONN="On-Demand : "
. I '$O(^PRCP(445,PRCPINPT,9,"B",DUZ,"")) S PRCPONN="(On-Demand) : "
. S PRCPONN=PRCPONN_X
D SET($S(PRCPTYPE="W":"Substitute Items: "_X,1:PRCPONN),LINE+3,COLUMN,CLREND)
D SET("",LINE+4,COLUMN,CLREND)
Q
;
;
DRUGACCT ; build drug accountability array
S LINE=31,COLUMN=40,CLREND=80
D SET("Drug Accountability ",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("Dispensing Unit ",LINE+1,COLUMN,CLREND,50)
D SET("Dispensing Unit Conv Fact",LINE+2,COLUMN,CLREND,51)
Q
;
;
SOURCES ; build sources array
N D,PRCPDA
S LINE=36,COLUMN=1,CLREND=80
D SET("Procurement Sources",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET("Mandatory Source ",LINE+0,37,CLREND,.4)
S PRCPDA=0 F LINE=37:1:44 S PRCPDA=$O(^PRCP(445,PRCPINPT,1,ITEMDA,5,PRCPDA)) Q:'PRCPDA S X=$G(^(+PRCPDA,0)) D
. I X="" D SET("",LINE,COLUMN,CLREND) Q
. S D=$E($$VENNAME^PRCPUX1($P(X,"^"))_$J("",34),1,34)_" U/R: "_$E($$UNITVAL^PRCPUX1($P(X,"^",3),$P(X,"^",2),"/")_$J("",10),1,10)_" CF: "_$P(X,"^",4)
. D SET(D,LINE,COLUMN,CLREND)
F LINE=LINE:1:44 D SET("",LINE,COLUMN,CLREND)
S PRCPDA=$O(^PRCP(445,PRCPINPT,1,ITEMDA,5,PRCPDA))
D SET($S('PRCPDA:"",1:" . . . more . . . (only first 8 displayed)"),LINE+1,COLUMN,CLREND)
Q
;
;
SET(STRING,LINE,COLUMN,CLREND,FIELD,ON,OFF) ; set array
I $G(FIELD) S STRING=STRING_": "_$G(PRCPDATA(445.01,ITEMDA,FIELD,"E"))
I STRING="" D SET^VALM10(LINE,$J("",80)) Q
I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLUMN,$L(STRING),ON,OFF)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEIL0 4703 printed Apr 09, 2024@21:19:51 Page 2
PRCPEIL0 ;WISC/RFJ-edit inventory items (build arrays) ; 9/20/06 11:02am
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ISSUNITS ; build issue units array
+1 SET LINE=9
SET COLUMN=1
SET CLREND=39
+2 DO SET("Issue Units ",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET("Unit per Issue: "_$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),LINE+1,COLUMN,CLREND)
+4 IF PRCPTYPE="P"
DO SET("Issue Multiple",LINE+2,COLUMN,CLREND,16)
+5 IF PRCPTYPE="P"
DO SET("Min Issue Qty ",LINE+3,COLUMN,CLREND,16.5)
+6 QUIT
+7 ;
+8 ;
COSTS ; build costs array
+1 SET LINE=16
SET COLUMN=40
SET CLREND=80
+2 DO SET("Costing Data",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET("Last Cost ",LINE+1,COLUMN,CLREND,4.7)
+4 DO SET("Average Cost",LINE+2,COLUMN,CLREND,4.8)
+5 DO SET("Total Value ",LINE+3,COLUMN,CLREND,4.81)
+6 QUIT
+7 ;
+8 ;
LEVELS ; build levels array
+1 SET LINE=9
SET COLUMN=40
SET CLREND=80
+2 DO SET("Levels ",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET("Norm Stock Level",LINE+1,COLUMN,CLREND,9)
+4 DO SET("Emer Stock Level",LINE+2,COLUMN,CLREND,11)
+5 DO SET("Temp Stock Level",LINE+3,COLUMN,CLREND,9.5)
+6 DO SET("Delete Temp SL ",LINE+4,COLUMN,CLREND,9.6)
+7 DO SET("Stand Reord Pt ",LINE+5,COLUMN,CLREND,10)
+8 DO SET("Option Reord Pt ",LINE+6,COLUMN,CLREND,10.3)
+9 QUIT
+10 ;
+11 ;
QUANTITY ; build quantities array
+1 SET LINE=16
SET COLUMN=1
SET CLREND=39
+2 DO SET("Quantities ",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET("On-hand ",LINE+1,COLUMN,CLREND,7)
+4 DO SET("Due-In ",LINE+2,COLUMN,CLREND,8.1)
+5 DO SET("Due-Out ",LINE+3,COLUMN,CLREND,8.6)
+6 DO SET($SELECT(PRCPTYPE="W":"Non-Issuable",1:""),LINE+4,COLUMN,CLREND,$SELECT(PRCPTYPE="W":7.5,1:0))
+7 DO SET("",LINE+5,COLUMN,80)
+8 QUIT
+9 ;
+10 ;
OUTSTRAN ; build outstanding transaction array
+1 NEW D,PRCPDA
+2 SET LINE=22
SET COLUMN=1
SET CLREND=80
+3 DO SET("Due-Ins/Outstanding Transactions",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+4 SET PRCPDA=0
FOR LINE=23:1:29
SET PRCPDA=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,7,PRCPDA))
if 'PRCPDA
QUIT
SET X=$GET(^(+PRCPDA,0))
Begin DoDot:1
+5 IF X=""
DO SET("",LINE,COLUMN,CLREND)
QUIT
+6 SET D=$EXTRACT($PIECE($GET(^PRCS(410,+$PIECE(X,"^"),0)),"^")_$JUSTIFY("",34),1,34)_" Qty: "_$EXTRACT($PIECE(X,"^",2)_$JUSTIFY("",8),1,8)_" U/R: "_$EXTRACT($$UNITVAL^PRCPUX1($PIECE(X,"^",4),$PIECE(X,"^",3),"/")_$JUSTIFY("",10),1,10)_"
CF: "_...
... $PIECE(X,"^",5)
+7 DO SET(D,LINE,COLUMN,CLREND)
End DoDot:1
+8 FOR LINE=LINE:1:29
DO SET("",LINE,COLUMN,CLREND)
+9 SET PRCPDA=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,7,PRCPDA))
+10 DO SET($SELECT('PRCPDA:"",1:" . . . more . . . (only first 7 displayed)"),LINE+1,COLUMN,CLREND)
+11 QUIT
+12 ;
+13 ;
SPECIAL ; build special parameter array
+1 ; subroutine modified to add On-Demand Items (PRC*5.1*98)
+2 NEW PRCPONN
SET PRCPONN=""
+3 SET LINE=31
SET COLUMN=1
SET CLREND=39
+4 DO SET("Special Parameters",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+5 DO SET("Kill When Zero ",LINE+1,COLUMN,CLREND,17)
+6 DO SET("",LINE+2,COLUMN,CLREND)
+7 SET X=""
+8 IF PRCPTYPE="W"
SET X=""
SET %=0
FOR
SET %=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,4,%))
if '%
QUIT
SET X=X_$SELECT(X="":"",1:", ")_%
+9 IF PRCPTYPE'="W"
Begin DoDot:1
+10 NEW X
+11 SET X=$$GET1^DIQ(445.01,ITEMDA_","_PRCPINPT_",",.8,"E")
+12 IF X']""
SET X="NO"
+13 SET PRCPONN="On-Demand : "
+14 IF '$ORDER(^PRCP(445,PRCPINPT,9,"B",DUZ,""))
SET PRCPONN="(On-Demand) : "
+15 SET PRCPONN=PRCPONN_X
End DoDot:1
+16 DO SET($SELECT(PRCPTYPE="W":"Substitute Items: "_X,1:PRCPONN),LINE+3,COLUMN,CLREND)
+17 DO SET("",LINE+4,COLUMN,CLREND)
+18 QUIT
+19 ;
+20 ;
DRUGACCT ; build drug accountability array
+1 SET LINE=31
SET COLUMN=40
SET CLREND=80
+2 DO SET("Drug Accountability ",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET("Dispensing Unit ",LINE+1,COLUMN,CLREND,50)
+4 DO SET("Dispensing Unit Conv Fact",LINE+2,COLUMN,CLREND,51)
+5 QUIT
+6 ;
+7 ;
SOURCES ; build sources array
+1 NEW D,PRCPDA
+2 SET LINE=36
SET COLUMN=1
SET CLREND=80
+3 DO SET("Procurement Sources",LINE+0,COLUMN,CLREND,0,IORVON,IORVOFF)
+4 DO SET("Mandatory Source ",LINE+0,37,CLREND,.4)
+5 SET PRCPDA=0
FOR LINE=37:1:44
SET PRCPDA=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,5,PRCPDA))
if 'PRCPDA
QUIT
SET X=$GET(^(+PRCPDA,0))
Begin DoDot:1
+6 IF X=""
DO SET("",LINE,COLUMN,CLREND)
QUIT
+7 SET D=$EXTRACT($$VENNAME^PRCPUX1($PIECE(X,"^"))_$JUSTIFY("",34),1,34)_" U/R: "_$EXTRACT($$UNITVAL^PRCPUX1($PIECE(X,"^",3),$PIECE(X,"^",2),"/")_$JUSTIFY("",10),1,10)_" CF: "_$PIECE(X,"^",4)
+8 DO SET(D,LINE,COLUMN,CLREND)
End DoDot:1
+9 FOR LINE=LINE:1:44
DO SET("",LINE,COLUMN,CLREND)
+10 SET PRCPDA=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,5,PRCPDA))
+11 DO SET($SELECT('PRCPDA:"",1:" . . . more . . . (only first 8 displayed)"),LINE+1,COLUMN,CLREND)
+12 QUIT
+13 ;
+14 ;
SET(STRING,LINE,COLUMN,CLREND,FIELD,ON,OFF) ; set array
+1 IF $GET(FIELD)
SET STRING=STRING_": "_$GET(PRCPDATA(445.01,ITEMDA,FIELD,"E"))
+2 IF STRING=""
DO SET^VALM10(LINE,$JUSTIFY("",80))
QUIT
+3 IF '$DATA(@VALMAR@(LINE,0))
DO SET^VALM10(LINE,$JUSTIFY("",80))
+4 DO SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
+5 IF $GET(ON)]""!($GET(OFF)]"")
DO CNTRL^VALM10(LINE,COLUMN,$LENGTH(STRING),ON,OFF)
+6 QUIT
