PRCPENL1.m

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 ---PRCPENL1   2718     printed  Apr 23, 2025@18:28:17                                                                                                                                                                                                    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