Routine: PRCPEIL0

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.

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)

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)

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)

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)

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)

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)

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)

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)

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEIL0   4703     printed  Mar 13, 2025@21:18:20                                                                                                                                                                                                    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

PRCPEIL0.m