PRCPENL1 ;WISC/RFJ,DGL-edit inventory parameters (list manager) ; 7/21/99 9:53am
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DISTRPTS ; build distribution points array
N %,DISTR
S LINE=LINE+1,COLUMN=1,CLREND=80
D SET^PRCPENLM("Distribution Points",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
S DISTR=0 F LINE=LINE+1:1 S DISTR=$O(^PRCP(445,PRCPINPT,2,DISTR)) Q:'DISTR D
. D SET^PRCPENLM(" : "_$$INVNAME^PRCPUX1(DISTR),LINE,COLUMN,CLREND)
. S %=$P($G(^PRCP(445,DISTR,0)),"^",3),%=$S(%="W":"WAREHOUSE",%="P":"PRIMARY",%="S":"SECONDARY",1:"<<NOT DEFINED>>")
. D SET^PRCPENLM(%,LINE,65,CLREND)
D SET^PRCPENLM("",LINE,COLUMN,CLREND)
Q
;
;
STOCKED ; build stocked by array
N %,DISTR
S LINE=LINE+1,COLUMN=1,CLREND=80
D SET^PRCPENLM("Stocked By Points",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
S DISTR=0 F LINE=LINE+1:1 S DISTR=$O(^PRCP(445,"AB",PRCPINPT,DISTR)) Q:'DISTR D
. D SET^PRCPENLM(" : "_$$INVNAME^PRCPUX1(DISTR),LINE,COLUMN,CLREND)
. S %=$P($G(^PRCP(445,DISTR,0)),"^",3),%=$S(%="W":"WAREHOUSE",%="P":"PRIMARY",%="S":"SECONDARY",1:"<<NOT DEFINED>>")
. D SET^PRCPENLM(%,LINE,65,CLREND)
Q
;
;
PURGE ; build purge date array
S LINE=LINE+1,COLUMN=1,CLREND=80
D SET^PRCPENLM("Purge Information",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET^PRCPENLM(" Automatic Purge",LINE,20,CLREND,7.9)
D SET^PRCPENLM("Usage Last Purged ",LINE+1,COLUMN,CLREND,7.5)
D SET^PRCPENLM("Receipts Last Purged ",LINE+2,COLUMN,CLREND,7.6)
D SET^PRCPENLM("Transaction Register Last Purged ",LINE+3,COLUMN,CLREND,7.7)
D SET^PRCPENLM("Distribution Statistics Last Purged ",LINE+4,COLUMN,CLREND,7.8)
S LINE=LINE+4
Q
;
;
FCP ; build fund control point array
N FCP,STATION
S LINE=LINE+1,COLUMN=1,CLREND=80
D SET^PRCPENLM("Fund Control Points",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
S STATION=0 F S STATION=$O(^PRC(420,"AE",STATION)) Q:'STATION S FCP=0 F S FCP=$O(^PRC(420,"AE",STATION,PRCPINPT,FCP)) Q:'FCP D
. S LINE=LINE+1
. D SET^PRCPENLM(" : "_$P($G(^PRC(420,STATION,1,FCP,0)),"^"),LINE,COLUMN,CLREND)
S LINE=LINE+1
D SET^PRCPENLM("",LINE,COLUMN,CLREND)
Q
;
;
MISCOSTS ; build mis costing section array
N %,SECT
S LINE=LINE+1,COLUMN=1,CLREND=80
D SET^PRCPENLM("MIS Costing Section",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
S SECT=0 F LINE=LINE+1:1 S SECT=$O(^PRCP(445,PRCPINPT,3,SECT)) Q:'SECT D
. S %=$G(^PRCP(445,PRCPINPT,3,SECT,0))
. D SET^PRCPENLM(" : "_$P($G(^DIC(49,+$P(%,"^"),0)),"^"),LINE,COLUMN,CLREND)
. D SET^PRCPENLM($J($P(%,"^",2),5)_" %",LINE,65,CLREND)
D SET^PRCPENLM("",LINE,COLUMN,CLREND)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPENL1 2718 printed Dec 13, 2024@02:13:47 Page 2
PRCPENL1 ;WISC/RFJ,DGL-edit inventory parameters (list manager) ; 7/21/99 9:53am
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
DISTRPTS ; build distribution points array
+1 NEW %,DISTR
+2 SET LINE=LINE+1
SET COLUMN=1
SET CLREND=80
+3 DO SET^PRCPENLM("Distribution Points",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+4 SET DISTR=0
FOR LINE=LINE+1:1
SET DISTR=$ORDER(^PRCP(445,PRCPINPT,2,DISTR))
if 'DISTR
QUIT
Begin DoDot:1
+5 DO SET^PRCPENLM(" : "_$$INVNAME^PRCPUX1(DISTR),LINE,COLUMN,CLREND)
+6 SET %=$PIECE($GET(^PRCP(445,DISTR,0)),"^",3)
SET %=$SELECT(%="W":"WAREHOUSE",%="P":"PRIMARY",%="S":"SECONDARY",1:"<<NOT DEFINED>>")
+7 DO SET^PRCPENLM(%,LINE,65,CLREND)
End DoDot:1
+8 DO SET^PRCPENLM("",LINE,COLUMN,CLREND)
+9 QUIT
+10 ;
+11 ;
STOCKED ; build stocked by array
+1 NEW %,DISTR
+2 SET LINE=LINE+1
SET COLUMN=1
SET CLREND=80
+3 DO SET^PRCPENLM("Stocked By Points",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+4 SET DISTR=0
FOR LINE=LINE+1:1
SET DISTR=$ORDER(^PRCP(445,"AB",PRCPINPT,DISTR))
if 'DISTR
QUIT
Begin DoDot:1
+5 DO SET^PRCPENLM(" : "_$$INVNAME^PRCPUX1(DISTR),LINE,COLUMN,CLREND)
+6 SET %=$PIECE($GET(^PRCP(445,DISTR,0)),"^",3)
SET %=$SELECT(%="W":"WAREHOUSE",%="P":"PRIMARY",%="S":"SECONDARY",1:"<<NOT DEFINED>>")
+7 DO SET^PRCPENLM(%,LINE,65,CLREND)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
PURGE ; build purge date array
+1 SET LINE=LINE+1
SET COLUMN=1
SET CLREND=80
+2 DO SET^PRCPENLM("Purge Information",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET^PRCPENLM(" Automatic Purge",LINE,20,CLREND,7.9)
+4 DO SET^PRCPENLM("Usage Last Purged ",LINE+1,COLUMN,CLREND,7.5)
+5 DO SET^PRCPENLM("Receipts Last Purged ",LINE+2,COLUMN,CLREND,7.6)
+6 DO SET^PRCPENLM("Transaction Register Last Purged ",LINE+3,COLUMN,CLREND,7.7)
+7 DO SET^PRCPENLM("Distribution Statistics Last Purged ",LINE+4,COLUMN,CLREND,7.8)
+8 SET LINE=LINE+4
+9 QUIT
+10 ;
+11 ;
FCP ; build fund control point array
+1 NEW FCP,STATION
+2 SET LINE=LINE+1
SET COLUMN=1
SET CLREND=80
+3 DO SET^PRCPENLM("Fund Control Points",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+4 SET STATION=0
FOR
SET STATION=$ORDER(^PRC(420,"AE",STATION))
if 'STATION
QUIT
SET FCP=0
FOR
SET FCP=$ORDER(^PRC(420,"AE",STATION,PRCPINPT,FCP))
if 'FCP
QUIT
Begin DoDot:1
+5 SET LINE=LINE+1
+6 DO SET^PRCPENLM(" : "_$PIECE($GET(^PRC(420,STATION,1,FCP,0)),"^"),LINE,COLUMN,CLREND)
End DoDot:1
+7 SET LINE=LINE+1
+8 DO SET^PRCPENLM("",LINE,COLUMN,CLREND)
+9 QUIT
+10 ;
+11 ;
MISCOSTS ; build mis costing section array
+1 NEW %,SECT
+2 SET LINE=LINE+1
SET COLUMN=1
SET CLREND=80
+3 DO SET^PRCPENLM("MIS Costing Section",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+4 SET SECT=0
FOR LINE=LINE+1:1
SET SECT=$ORDER(^PRCP(445,PRCPINPT,3,SECT))
if 'SECT
QUIT
Begin DoDot:1
+5 SET %=$GET(^PRCP(445,PRCPINPT,3,SECT,0))
+6 DO SET^PRCPENLM(" : "_$PIECE($GET(^DIC(49,+$PIECE(%,"^"),0)),"^"),LINE,COLUMN,CLREND)
+7 DO SET^PRCPENLM($JUSTIFY($PIECE(%,"^",2),5)_" %",LINE,65,CLREND)
End DoDot:1
+8 DO SET^PRCPENLM("",LINE,COLUMN,CLREND)
+9 QUIT
