source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRDIS.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
RevLine 
[613]1PRCPRDIS ;WISC/CC-supply station quantity discrepancy report ;4/00
2V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="S"
5 D ^PRCPUSEL Q:'$G(PRCP("I"))
6 I PRCP("DPTYPE")'="S" Q
7 I $P($G(^PRCP(445,PRCP("I"),5)),"^",1)']"" Q
8 ;
9 N %,I,INVPT,PRCPINNM,X,XP,XH,Y
10 S INVPT=PRCP("I"),PRCPINNM=$$INVNAME^PRCPUX1(INVPT)
11 ;
12 K X S X(1)="This report displays items whose on-hand quantity in "_PRCPINNM_" differs from the supply station's on-hand amount"
13 D DISPLAY^PRCPUX2(40,79,.X)
14 ;
15 K X
16 S Y=$P($G(^PRCP(445,PRCP("I"),6)),"^",1)
17 I Y']"" S X(1)="No QOH information was ever received. It is recommended you request a QOH update."
18 I Y]"" D
19 . X ^DD("DD")
20 . S I=$P(Y,"@",1),Y=$P(Y,"@",2,99)
21 . S X(1)="The Last QOH update was received on "_I
22 . I Y]"" S X(1)=X(1)_" at "_Y_"."
23 . S X(2)="If this date is too old, you may now request an update."
24 D DISPLAY^PRCPUX2(2,40,.X)
25 S XP="Do you want to request a refresh of the supply station QOH"
26 S XH(1)="Enter YES to request the supply station send a QOH update to GIP,"
27 S XH(2)="Enter NO to continue with the report using what has already been received,"
28 S XH(3)="Enter '^' to exit."
29 S %=$$YN^PRCPUYN(2) I '% Q
30 I %'=1,%'=2 Q
31 I %=1 D Q
32 . W !
33 . D EN^DDIOL("Sending request...")
34 . D EN^DDIOL("Please give GIP time to get the information before printing the report.")
35 . D BLDSEG^PRCPHLQU(INVPT)
36 ;
37 W ! S %ZIS="Q" D ^%ZIS Q:POP
38 I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
39 . S ZTDESC="Item discrepancy report",ZTRTN="PRINT^PRCPRDIS"
40 . S ZTSAVE("PRCP*")=""
41 W !!,"<*> please wait <*>"
42 ;
43PRINT N %,GIPCNT,INVPT,ITEM,NOW,PAGE,REFILL,SCREEN,SSCNT,X,Y
44 D NOW^%DTC S Y=% D DD^%DT S NOW=Y
45 S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
46 S INVPT=PRCP("I")
47 S ITEM=0
48 F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q
49 . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item
50 . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7)
51 . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1)
52 . I 'GIPCNT,'SSCNT Q
53 . I GIPCNT=SSCNT Q
54 . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
55 . ; W !,$J(ITEM,7)," ",$P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
56 . ; W !,"GIP: ",$J(GIPCNT,7)," SUPPLY STATION: ",$J(SSCNT,7)
57 . W $J(GIPCNT,7)," ",$J(SSCNT,7)
58 . S Y=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",2)
59 . I Y']"" W " "
60 . I Y]"" D
61 . . X ^DD("DD")
62 . . W $J(" ("_Y_")",23)
63 . W " ",$J(ITEM,7)," ",$E($P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1),1,32)
64 . S REFILL=$$REFILLS(ITEM,INVPT) I REFILL]"" W !,?8,REFILL
65 . W !
66 ;
67 I '$G(PRCPFLAG) D END^PRCPUREP
68 D ^%ZISC Q
69 ;
70REFILLS(ITEMDA,PRCPINPT) ; is the item refilled in an unposted order
71 ; ITEMDA = DA of item
72 ; PRCPINT = DA of inventory point
73 ;
74 N ORD,OUTORD,PRIMVN,REFILL,X
75 S ORD=0,OUTORD=0,REFILL=""
76 F S ORD=$O(^PRCP(445.3,"AD",PRCPINPT,ORD)) Q:+ORD'>0 D
77 . S X=^PRCP(445.3,ORD,0)
78 . I $P(X,"^",10)]"",$P(X,"^",6)="R",$D(^PRCP(445.3,ORD,1,ITEMDA)),($P(X,"^",8))="R" D
79 . . I $P(^PRCP(445.3,ORD,1,ITEMDA,0),"^",7) D
80 . . . I OUTORD S REFILL=REFILL_"; "
81 . . . I 'OUTORD S REFILL=REFILL_"unposted refills: " S OUTORD=1
82 . . . S REFILL=REFILL_"ORD# "_$P(^PRCP(445.3,ORD,0),"^",1)
83 . . . S PRIMVN=$P(X,"^",2)_";PRCP(445,"
84 . . . S X=$$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRIMVN,1)
85 . . . S X=$P(X,"^",4) ; pkg multiple (conversion factor)
86 . . . I 'X S X=1
87 . . . S REFILL=REFILL_"("_($P(^PRCP(445.3,ORD,1,ITEMDA,0),"^",7)*X)_")"
88 Q REFILL
89 ;
90H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
91 W $C(13),"SUPPLY STATION QUANTITY DISCREPANCY REPORT",?(IOM-$L(%)),%
92 W !,"FOR: ",PRCPINNM,!
93 W !,?2,"GIP",?19,"SUPPLY STATION"
94 W !,"QTY NOW QTY (AS OF DATE and TIME) ITEM NUMBER AND DESCRIPTION"
95 ; W !,"ITEM NUMBER AND DESCRIPTION"
96 ; 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)
97 S %="",$P(%,"-",IOM+1)="" W !,%,!
98 Q
Note: See TracBrowser for help on using the repository browser.