- PRCPRCAT ;WISC/RFJ/DL-order form ; 1/28/98 1000
- V ;;5.1;IFCAP;**1,132**;Oct 20, 2000;Build 3
- ;Per VHA Directive 2004-038, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N PRCPBLNK,PRCPDATE,PRCPEND,PRCPINFR,PRCPINPT,PRCPFLAG,PRCPFONE,PRCPFNON,PRCPSSIT,X,Y,Z
- K X S X(1)="The Order Form prints the current or selected inventory point's items sorted by main storage location and description. Blanks for daily ordering may be included."
- D DISPLAY^PRCPUX2(40,79,.X)
- ;
- I PRCP("DPTYPE")="S" S PRCPINPT=PRCP("I") G MONTHYR
- ;
- K X S X(1)="Select a Distribution Point or press the <return> key to select the current inventory point."
- D DISPLAY^PRCPUX2(2,40,.X)
- S PRCPINPT=$$TO^PRCPUDPT(PRCP("I")) Q:PRCPINPT["^"
- I 'PRCPINPT S PRCPINPT=PRCP("I")
- ;
- ; jump to here if a secondary
- MONTHYR W ! K X S X(1)="Select the month-year of the order form for "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- D DISPLAY^PRCPUX2(2,40,.X)
- S %DT("A")="Print Catalog/Order Form for DATE: "
- S %DT("B")="TODAY",%DT="AEX" D ^%DT K %DT Q:Y<0
- S PRCPEND=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",+$E(Y,4,5))
- I PRCPEND=28 S Z=$E(Y,1,3)+1700,PRCPEND=$S(Z#400=0:29,(Z#4=0&(Z#100'=0)):29,1:28)
- S Y=$E(Y,1,5)_"00" D DD^%DT S PRCPDATE=Y
- ;
- D Q:$G(PRCPFLAG) G BLANKS:$P($G(^PRCP(445,PRCPINPT,0)),"^",3)="S"
- . S PRCPSSIT=1
- . S XP="Print only items with a non-zero normal level"
- . S XH="Enter YES to print only items whose normal level is not zero in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- . S XH(1)="Enter NO to print all items in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- . S XH(2)="Enter ^ to exit."
- . W ! S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
- . I %=2 K PRCPSSIT
- ;
- S PRCPINFR=$$FROMCHEK^PRCPUDPT(PRCPINPT,0)
- I PRCPINFR D Q:$G(PRCPFLAG)
- . S XP="Print only the items stocked by "_$$INVNAME^PRCPUX1(PRCPINFR)
- . S XH="Enter YES to only print the items stocked by "_$$INVNAME^PRCPUX1(PRCPINFR)_"."
- . S XH(1)="Enter NO to print all items in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- . S XH(2)="Enter ^ to exit."
- . W ! S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
- . I %=2 K PRCPINFR
- ;
- BLANKS S PRCPBLNK=1
- I "SP"[(PRCP("DPTYPE")) D
- . S XP="Include blanks on printout"
- . S XH="Enter YES to print blanks on the order form."
- . S XH(1)="Enter NO to print just the items and related information."
- . S XH(2)="Enter ^ to exit."
- . W ! S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
- . I %=2 K PRCPBLNK
- ;
- S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
- . S ZTDESC="Order Form",ZTRTN="DQ^PRCPRCAT"
- . S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- ;
- ; queue comes here
- DQ N %I,DAY,DAY1,DESCR,ITEMCOST,ITEMDA,ITEMDATA,MAINLOC,NOW,PAGE,PRCPFLAG,PRCPINNM,SCREEN,WHSESRCE,X,Y
- K ^TMP($J,"PRCPRCAT")
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCPINPT,1,ITEMDA)) Q:'ITEMDA D
- . I $G(PRCPINFR),'$D(^PRCP(445,PRCPINFR,1,ITEMDA,0)) Q
- . I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) Q
- . I $G(PRCPSSIT),$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)'>0 Q
- . S MAINLOC=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
- . S DESCR=$$DESCR^PRCPUX1(PRCPINPT,ITEMDA) S:DESCR="" DESCR=" "
- . S ^TMP($J,"PRCPRCAT",MAINLOC,$E(DESCR,1,20),ITEMDA)=""
- ;
- ; setup order form format
- S DAY="" F %=1:1:PRCPEND S DAY=DAY_"| "_$J(%,2)
- I IOM<81 S DAY1="|"_$P(DAY,"15|",2),DAY=$P(DAY,"15|")_"15"
- ;
- S WHSESRCE=+$O(^PRC(440,"AC","W",0))
- S PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP,PAGE=1 U IO D H
- S MAINLOC="" F S MAINLOC=$O(^TMP($J,"PRCPRCAT",MAINLOC)) Q:MAINLOC=""!($G(PRCPFLAG)) D
- . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
- . I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
- . W !!?5,"MAIN STORAGE LOCATION: ",$S(MAINLOC=" ":"<< NONE >>",1:MAINLOC)
- . I '$G(PRCPBLNK) W !
- . S DESCR="" F S DESCR=$O(^TMP($J,"PRCPRCAT",MAINLOC,DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRCAT",MAINLOC,DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
- . . I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
- . . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- . . S ITEMCOST=$P(ITEMDATA,"^",22) I $P(ITEMDATA,"^",15)>ITEMCOST S ITEMCOST=$P(ITEMDATA,"^",15)
- . . I $G(PRCPBLNK) W !!
- . . W $E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,28),?29,ITEMDA,?35,$TR($$NSN^PRCPUX1(ITEMDA),"-"),?50,$J($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"/"),8),$J($P(ITEMDATA,"^",10),6),$J($P(ITEMDATA,"^",9),6),$J(ITEMCOST,9,2),!
- . . I $$MANDSRCE^PRCPU441(ITEMDA)=WHSESRCE W "*"
- . . I $G(PRCPBLNK) D
- . . . W ?2,"DAY: ",DAY,"|",!?2,"QTY: ",$TR(DAY,"1234567890"," "),"|"
- . . . I $D(DAY1) W !?2,"DAY: ",DAY1,"|",!?2,"QTY: ",$TR(DAY1,"1234567890"," "),"|"
- I '$G(PRCPFLAG) D END^PRCPUREP
- K ^TMP($J,"PRCPRCAT") D ^%ZISC Q
- ;
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"ORDER FORM FOR: ",PRCPINNM,?(IOM-$L(%)),%
- W !?5,"FOR THE MONTH-YEAR: ",PRCPDATE
- W ?58,$J("STAND",6),$J("NORM",6),$J("UNIT",10),!,"DESCRIPTION",?29,"MI#",?35,"NSN",?50,$J("UNIT/IS",8),$J("REOPT",6),$J("STLVL",6),$J("COST",10)
- S %="",$P(%,"-",IOM+1)="" W !,%,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRCAT 5248 printed Apr 23, 2025@18:29:07 Page 2
- PRCPRCAT ;WISC/RFJ/DL-order form ; 1/28/98 1000
- V ;;5.1;IFCAP;**1,132**;Oct 20, 2000;Build 3
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +3 NEW PRCPBLNK,PRCPDATE,PRCPEND,PRCPINFR,PRCPINPT,PRCPFLAG,PRCPFONE,PRCPFNON,PRCPSSIT,X,Y,Z
- +4 KILL X
- SET X(1)="The Order Form prints the current or selected inventory point's items sorted by main storage location and description. Blanks for daily ordering may be included."
- +5 DO DISPLAY^PRCPUX2(40,79,.X)
- +6 ;
- +7 IF PRCP("DPTYPE")="S"
- SET PRCPINPT=PRCP("I")
- GOTO MONTHYR
- +8 ;
- +9 KILL X
- SET X(1)="Select a Distribution Point or press the <return> key to select the current inventory point."
- +10 DO DISPLAY^PRCPUX2(2,40,.X)
- +11 SET PRCPINPT=$$TO^PRCPUDPT(PRCP("I"))
- if PRCPINPT["^"
- QUIT
- +12 IF 'PRCPINPT
- SET PRCPINPT=PRCP("I")
- +13 ;
- +14 ; jump to here if a secondary
- MONTHYR WRITE !
- KILL X
- SET X(1)="Select the month-year of the order form for "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- +1 DO DISPLAY^PRCPUX2(2,40,.X)
- +2 SET %DT("A")="Print Catalog/Order Form for DATE: "
- +3 SET %DT("B")="TODAY"
- SET %DT="AEX"
- DO ^%DT
- KILL %DT
- if Y<0
- QUIT
- +4 SET PRCPEND=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",+$EXTRACT(Y,4,5))
- +5 IF PRCPEND=28
- SET Z=$EXTRACT(Y,1,3)+1700
- SET PRCPEND=$SELECT(Z#400=0:29,(Z#4=0&(Z#100'=0)):29,1:28)
- +6 SET Y=$EXTRACT(Y,1,5)_"00"
- DO DD^%DT
- SET PRCPDATE=Y
- +7 ;
- +8 Begin DoDot:1
- +9 SET PRCPSSIT=1
- +10 SET XP="Print only items with a non-zero normal level"
- +11 SET XH="Enter YES to print only items whose normal level is not zero in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- +12 SET XH(1)="Enter NO to print all items in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- +13 SET XH(2)="Enter ^ to exit."
- +14 WRITE !
- SET %=$$YN^PRCPUYN(1)
- IF %<1
- SET PRCPFLAG=1
- QUIT
- +15 IF %=2
- KILL PRCPSSIT
- End DoDot:1
- if $GET(PRCPFLAG)
- QUIT
- if $PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",3)="S"
- GOTO BLANKS
- +16 ;
- +17 SET PRCPINFR=$$FROMCHEK^PRCPUDPT(PRCPINPT,0)
- +18 IF PRCPINFR
- Begin DoDot:1
- +19 SET XP="Print only the items stocked by "_$$INVNAME^PRCPUX1(PRCPINFR)
- +20 SET XH="Enter YES to only print the items stocked by "_$$INVNAME^PRCPUX1(PRCPINFR)_"."
- +21 SET XH(1)="Enter NO to print all items in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
- +22 SET XH(2)="Enter ^ to exit."
- +23 WRITE !
- SET %=$$YN^PRCPUYN(1)
- IF %<1
- SET PRCPFLAG=1
- QUIT
- +24 IF %=2
- KILL PRCPINFR
- End DoDot:1
- if $GET(PRCPFLAG)
- QUIT
- +25 ;
- BLANKS SET PRCPBLNK=1
- +1 IF "SP"[(PRCP("DPTYPE"))
- Begin DoDot:1
- +2 SET XP="Include blanks on printout"
- +3 SET XH="Enter YES to print blanks on the order form."
- +4 SET XH(1)="Enter NO to print just the items and related information."
- +5 SET XH(2)="Enter ^ to exit."
- +6 WRITE !
- SET %=$$YN^PRCPUYN(1)
- IF %<1
- SET PRCPFLAG=1
- QUIT
- +7 IF %=2
- KILL PRCPBLNK
- End DoDot:1
- +8 ;
- +9 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +10 SET ZTDESC="Order Form"
- SET ZTRTN="DQ^PRCPRCAT"
- +11 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- QUIT
- +12 WRITE !!,"<*> please wait <*>"
- +13 ;
- +14 ; queue comes here
- DQ NEW %I,DAY,DAY1,DESCR,ITEMCOST,ITEMDA,ITEMDATA,MAINLOC,NOW,PAGE,PRCPFLAG,PRCPINNM,SCREEN,WHSESRCE,X,Y
- +1 KILL ^TMP($JOB,"PRCPRCAT")
- +2 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA))
- if 'ITEMDA
- QUIT
- Begin DoDot:1
- +3 IF $GET(PRCPINFR)
- IF '$DATA(^PRCP(445,PRCPINFR,1,ITEMDA,0))
- QUIT
- +4 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- QUIT
- +5 IF $GET(PRCPSSIT)
- IF $PIECE(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)'>0
- QUIT
- +6 SET MAINLOC=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
- +7 SET DESCR=$$DESCR^PRCPUX1(PRCPINPT,ITEMDA)
- if DESCR=""
- SET DESCR=" "
- +8 SET ^TMP($JOB,"PRCPRCAT",MAINLOC,$EXTRACT(DESCR,1,20),ITEMDA)=""
- End DoDot:1
- +9 ;
- +10 ; setup order form format
- +11 SET DAY=""
- FOR %=1:1:PRCPEND
- SET DAY=DAY_"| "_$JUSTIFY(%,2)
- +12 IF IOM<81
- SET DAY1="|"_$PIECE(DAY,"15|",2)
- SET DAY=$PIECE(DAY,"15|")_"15"
- +13 ;
- +14 SET WHSESRCE=+$ORDER(^PRC(440,"AC","W",0))
- +15 SET PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
- +16 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- SET PAGE=1
- USE IO
- DO H
- +17 SET MAINLOC=""
- FOR
- SET MAINLOC=$ORDER(^TMP($JOB,"PRCPRCAT",MAINLOC))
- if MAINLOC=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:1
- +18 IF $GET(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET PRCPFLAG=1
- WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
- QUIT
- +19 IF $Y>(IOSL-7)
- if SCREEN
- DO P^PRCPUREP
- if $GET(PRCPFLAG)
- QUIT
- DO H
- +20 WRITE !!?5,"MAIN STORAGE LOCATION: ",$SELECT(MAINLOC=" ":"<< NONE >>",1:MAINLOC)
- +21 IF '$GET(PRCPBLNK)
- WRITE !
- +22 SET DESCR=""
- FOR
- SET DESCR=$ORDER(^TMP($JOB,"PRCPRCAT",MAINLOC,DESCR))
- if DESCR=""!($GET(PRCPFLAG))
- QUIT
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRCAT",MAINLOC,DESCR,ITEMDA))
- if 'ITEMDA!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:2
- +23 IF $Y>(IOSL-8)
- if SCREEN
- DO P^PRCPUREP
- if $GET(PRCPFLAG)
- QUIT
- DO H
- +24 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- +25 SET ITEMCOST=$PIECE(ITEMDATA,"^",22)
- IF $PIECE(ITEMDATA,"^",15)>ITEMCOST
- SET ITEMCOST=$PIECE(ITEMDATA,"^",15)
- +26 IF $GET(PRCPBLNK)
- WRITE !!
- +27 WRITE $EXTRACT($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,28),?29,ITEMDA,?35,$TRANSLATE($$NSN^PRCPUX1(ITEMDA),"-"),?50,$JUSTIFY($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"/"),8),$JUSTIFY($PIECE(ITEMDATA,"^",10),6),$JUSTIFY($PIECE(ITEMDATA,"^",
- 9),6),$JUSTIFY(ITEMCOST,9,2),!
- +28 IF $$MANDSRCE^PRCPU441(ITEMDA)=WHSESRCE
- WRITE "*"
- +29 IF $GET(PRCPBLNK)
- Begin DoDot:3
- +30 WRITE ?2,"DAY: ",DAY,"|",!?2,"QTY: ",$TRANSLATE(DAY,"1234567890"," "),"|"
- +31 IF $DATA(DAY1)
- WRITE !?2,"DAY: ",DAY1,"|",!?2,"QTY: ",$TRANSLATE(DAY1,"1234567890"," "),"|"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 IF '$GET(PRCPFLAG)
- DO END^PRCPUREP
- +33 KILL ^TMP($JOB,"PRCPRCAT")
- DO ^%ZISC
- QUIT
- +34 ;
- +35 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"ORDER FORM FOR: ",PRCPINNM,?(IOM-$LENGTH(%)),%
- +2 WRITE !?5,"FOR THE MONTH-YEAR: ",PRCPDATE
- +3 WRITE ?58,$JUSTIFY("STAND",6),$JUSTIFY("NORM",6),$JUSTIFY("UNIT",10),!,"DESCRIPTION",?29,"MI#",?35,"NSN",?50,$JUSTIFY("UNIT/IS",8),$JUSTIFY("REOPT",6),$JUSTIFY("STLVL",6),$JUSTIFY("COST",10)
- +4 SET %=""
- SET $PIECE(%,"-",IOM+1)=""
- WRITE !,%,!
- +5 QUIT
