- PRCPRDIS ;WISC/CC-supply station quantity discrepancy report ;4/00
- V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="S"
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- I PRCP("DPTYPE")'="S" Q
- I $P($G(^PRCP(445,PRCP("I"),5)),"^",1)']"" Q
- ;
- N %,I,INVPT,PRCPINNM,X,XP,XH,Y
- S INVPT=PRCP("I"),PRCPINNM=$$INVNAME^PRCPUX1(INVPT)
- ;
- K X S X(1)="This report displays items whose on-hand quantity in "_PRCPINNM_" differs from the supply station's on-hand amount"
- D DISPLAY^PRCPUX2(40,79,.X)
- ;
- K X
- S Y=$P($G(^PRCP(445,PRCP("I"),6)),"^",1)
- I Y']"" S X(1)="No QOH information was ever received. It is recommended you request a QOH update."
- I Y]"" D
- . X ^DD("DD")
- . S I=$P(Y,"@",1),Y=$P(Y,"@",2,99)
- . S X(1)="The Last QOH update was received on "_I
- . I Y]"" S X(1)=X(1)_" at "_Y_"."
- . S X(2)="If this date is too old, you may now request an update."
- D DISPLAY^PRCPUX2(2,40,.X)
- S XP="Do you want to request a refresh of the supply station QOH"
- S XH(1)="Enter YES to request the supply station send a QOH update to GIP,"
- S XH(2)="Enter NO to continue with the report using what has already been received,"
- S XH(3)="Enter '^' to exit."
- S %=$$YN^PRCPUYN(2) I '% Q
- I %'=1,%'=2 Q
- I %=1 D Q
- . W !
- . D EN^DDIOL("Sending request...")
- . D EN^DDIOL("Please give GIP time to get the information before printing the report.")
- . D BLDSEG^PRCPHLQU(INVPT)
- ;
- W ! S %ZIS="Q" D ^%ZIS Q:POP
- I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
- . S ZTDESC="Item discrepancy report",ZTRTN="PRINT^PRCPRDIS"
- . S ZTSAVE("PRCP*")=""
- W !!,"<*> please wait <*>"
- ;
- PRINT N %,GIPCNT,INVPT,ITEM,NOW,PAGE,REFILL,SCREEN,SSCNT,X,Y
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y
- S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
- S INVPT=PRCP("I")
- S ITEM=0
- F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q
- . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item
- . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7)
- . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1)
- . I 'GIPCNT,'SSCNT Q
- . I GIPCNT=SSCNT Q
- . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . ; W !,$J(ITEM,7)," ",$P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
- . ; W !,"GIP: ",$J(GIPCNT,7)," SUPPLY STATION: ",$J(SSCNT,7)
- . W $J(GIPCNT,7)," ",$J(SSCNT,7)
- . S Y=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",2)
- . I Y']"" W " "
- . I Y]"" D
- . . X ^DD("DD")
- . . W $J(" ("_Y_")",23)
- . W " ",$J(ITEM,7)," ",$E($P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1),1,32)
- . S REFILL=$$REFILLS(ITEM,INVPT) I REFILL]"" W !,?8,REFILL
- . W !
- ;
- I '$G(PRCPFLAG) D END^PRCPUREP
- D ^%ZISC Q
- ;
- REFILLS(ITEMDA,PRCPINPT) ; is the item refilled in an unposted order
- ; ITEMDA = DA of item
- ; PRCPINT = DA of inventory point
- ;
- N ORD,OUTORD,PRIMVN,REFILL,X
- S ORD=0,OUTORD=0,REFILL=""
- F S ORD=$O(^PRCP(445.3,"AD",PRCPINPT,ORD)) Q:+ORD'>0 D
- . S X=^PRCP(445.3,ORD,0)
- . I $P(X,"^",10)]"",$P(X,"^",6)="R",$D(^PRCP(445.3,ORD,1,ITEMDA)),($P(X,"^",8))="R" D
- . . I $P(^PRCP(445.3,ORD,1,ITEMDA,0),"^",7) D
- . . . I OUTORD S REFILL=REFILL_"; "
- . . . I 'OUTORD S REFILL=REFILL_"unposted refills: " S OUTORD=1
- . . . S REFILL=REFILL_"ORD# "_$P(^PRCP(445.3,ORD,0),"^",1)
- . . . S PRIMVN=$P(X,"^",2)_";PRCP(445,"
- . . . S X=$$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRIMVN,1)
- . . . S X=$P(X,"^",4) ; pkg multiple (conversion factor)
- . . . I 'X S X=1
- . . . S REFILL=REFILL_"("_($P(^PRCP(445.3,ORD,1,ITEMDA,0),"^",7)*X)_")"
- Q REFILL
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"SUPPLY STATION QUANTITY DISCREPANCY REPORT",?(IOM-$L(%)),%
- W !,"FOR: ",PRCPINNM,!
- W !,?2,"GIP",?19,"SUPPLY STATION"
- W !,"QTY NOW QTY (AS OF DATE and TIME) ITEM NUMBER AND DESCRIPTION"
- ; W !,"ITEM NUMBER AND DESCRIPTION"
- ; 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[HPRCPRDIS 4064 printed Jan 18, 2025@03:16 Page 2
- PRCPRDIS ;WISC/CC-supply station quantity discrepancy report ;4/00
- V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 IF '$DATA(PRCP("DPTYPE"))
- SET PRCP("DPTYPE")="S"
- +3 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +4 IF PRCP("DPTYPE")'="S"
- QUIT
- +5 IF $PIECE($GET(^PRCP(445,PRCP("I"),5)),"^",1)']""
- QUIT
- +6 ;
- +7 NEW %,I,INVPT,PRCPINNM,X,XP,XH,Y
- +8 SET INVPT=PRCP("I")
- SET PRCPINNM=$$INVNAME^PRCPUX1(INVPT)
- +9 ;
- +10 KILL X
- SET X(1)="This report displays items whose on-hand quantity in "_PRCPINNM_" differs from the supply station's on-hand amount"
- +11 DO DISPLAY^PRCPUX2(40,79,.X)
- +12 ;
- +13 KILL X
- +14 SET Y=$PIECE($GET(^PRCP(445,PRCP("I"),6)),"^",1)
- +15 IF Y']""
- SET X(1)="No QOH information was ever received. It is recommended you request a QOH update."
- +16 IF Y]""
- Begin DoDot:1
- +17 XECUTE ^DD("DD")
- +18 SET I=$PIECE(Y,"@",1)
- SET Y=$PIECE(Y,"@",2,99)
- +19 SET X(1)="The Last QOH update was received on "_I
- +20 IF Y]""
- SET X(1)=X(1)_" at "_Y_"."
- +21 SET X(2)="If this date is too old, you may now request an update."
- End DoDot:1
- +22 DO DISPLAY^PRCPUX2(2,40,.X)
- +23 SET XP="Do you want to request a refresh of the supply station QOH"
- +24 SET XH(1)="Enter YES to request the supply station send a QOH update to GIP,"
- +25 SET XH(2)="Enter NO to continue with the report using what has already been received,"
- +26 SET XH(3)="Enter '^' to exit."
- +27 SET %=$$YN^PRCPUYN(2)
- IF '%
- QUIT
- +28 IF %'=1
- IF %'=2
- QUIT
- +29 IF %=1
- Begin DoDot:1
- +30 WRITE !
- +31 DO EN^DDIOL("Sending request...")
- +32 DO EN^DDIOL("Please give GIP time to get the information before printing the report.")
- +33 DO BLDSEG^PRCPHLQU(INVPT)
- End DoDot:1
- QUIT
- +34 ;
- +35 WRITE !
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +36 IF $DATA(IO("Q"))
- Begin DoDot:1
- +37 SET ZTDESC="Item discrepancy report"
- SET ZTRTN="PRINT^PRCPRDIS"
- +38 SET ZTSAVE("PRCP*")=""
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- QUIT
- +39 WRITE !!,"<*> please wait <*>"
- +40 ;
- PRINT NEW %,GIPCNT,INVPT,ITEM,NOW,PAGE,REFILL,SCREEN,SSCNT,X,Y
- +1 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- +2 SET PAGE=1
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- USE IO
- DO H
- +3 SET INVPT=PRCP("I")
- +4 SET ITEM=0
- +5 FOR
- SET ITEM=$ORDER(^PRCP(445,INVPT,1,ITEM))
- if '+ITEM
- QUIT
- Begin DoDot:1
- +6 ; not a SS item
- IF $PIECE($GET(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1
- QUIT
- +7 SET GIPCNT=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,0)),"^",7)
- +8 SET SSCNT=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,9)),"^",1)
- +9 IF 'GIPCNT
- IF 'SSCNT
- QUIT
- +10 IF GIPCNT=SSCNT
- QUIT
- +11 IF $Y>(IOSL-4)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- +12 ; W !,$J(ITEM,7)," ",$P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
- +13 ; W !,"GIP: ",$J(GIPCNT,7)," SUPPLY STATION: ",$J(SSCNT,7)
- +14 WRITE $JUSTIFY(GIPCNT,7)," ",$JUSTIFY(SSCNT,7)
- +15 SET Y=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,9)),"^",2)
- +16 IF Y']""
- WRITE " "
- +17 IF Y]""
- Begin DoDot:2
- +18 XECUTE ^DD("DD")
- +19 WRITE $JUSTIFY(" ("_Y_")",23)
- End DoDot:2
- +20 WRITE " ",$JUSTIFY(ITEM,7)," ",$EXTRACT($PIECE($GET(^PRCP(445,INVPT,1,ITEM,6)),"^",1),1,32)
- +21 SET REFILL=$$REFILLS(ITEM,INVPT)
- IF REFILL]""
- WRITE !,?8,REFILL
- +22 WRITE !
- End DoDot:1
- IF $DATA(PRCPFLAG)
- QUIT
- +23 ;
- +24 IF '$GET(PRCPFLAG)
- DO END^PRCPUREP
- +25 DO ^%ZISC
- QUIT
- +26 ;
- REFILLS(ITEMDA,PRCPINPT) ; is the item refilled in an unposted order
- +1 ; ITEMDA = DA of item
- +2 ; PRCPINT = DA of inventory point
- +3 ;
- +4 NEW ORD,OUTORD,PRIMVN,REFILL,X
- +5 SET ORD=0
- SET OUTORD=0
- SET REFILL=""
- +6 FOR
- SET ORD=$ORDER(^PRCP(445.3,"AD",PRCPINPT,ORD))
- if +ORD'>0
- QUIT
- Begin DoDot:1
- +7 SET X=^PRCP(445.3,ORD,0)
- +8 IF $PIECE(X,"^",10)]""
- IF $PIECE(X,"^",6)="R"
- IF $DATA(^PRCP(445.3,ORD,1,ITEMDA))
- IF ($PIECE(X,"^",8))="R"
- Begin DoDot:2
- +9 IF $PIECE(^PRCP(445.3,ORD,1,ITEMDA,0),"^",7)
- Begin DoDot:3
- +10 IF OUTORD
- SET REFILL=REFILL_"; "
- +11 IF 'OUTORD
- SET REFILL=REFILL_"unposted refills: "
- SET OUTORD=1
- +12 SET REFILL=REFILL_"ORD# "_$PIECE(^PRCP(445.3,ORD,0),"^",1)
- +13 SET PRIMVN=$PIECE(X,"^",2)_";PRCP(445,"
- +14 SET X=$$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRIMVN,1)
- +15 ; pkg multiple (conversion factor)
- SET X=$PIECE(X,"^",4)
- +16 IF 'X
- SET X=1
- +17 SET REFILL=REFILL_"("_($PIECE(^PRCP(445.3,ORD,1,ITEMDA,0),"^",7)*X)_")"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +18 QUIT REFILL
- +19 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"SUPPLY STATION QUANTITY DISCREPANCY REPORT",?(IOM-$LENGTH(%)),%
- +2 WRITE !,"FOR: ",PRCPINNM,!
- +3 WRITE !,?2,"GIP",?19,"SUPPLY STATION"
- +4 WRITE !,"QTY NOW QTY (AS OF DATE and TIME) ITEM NUMBER AND DESCRIPTION"
- +5 ; W !,"ITEM NUMBER AND DESCRIPTION"
- +6 ; 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)
- +7 SET %=""
- SET $PIECE(%,"-",IOM+1)=""
- WRITE !,%,!
- +8 QUIT