- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m
r613 r623 1 PRCPUSEL 2 V ;;5.1;IFCAP;**1,83,110**;Oct 20, 2000;Build 73 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$G(PRCP(I)) S %=1 Q23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 V1 54 55 56 DISPLAY 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 NOMENU 97 98 99 100 101 102 103 PARAM(INVPT) 104 105 106 107 108 109 110 111 112 TERM 113 114 115 116 117 118 119 120 SSMSG 121 122 123 124 125 126 127 128 129 130 131 1 PRCPUSEL ;WISC/RFJ/DAP-utilities: setup inventory variables ;14 Feb 91 2 V ;;5.1;IFCAP;**1,83**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; enter distribution point--input variables: 5 ; prcp("dptype")=distribution point type code [W,P,S] 6 ; returns the following variables: 7 ; prcp("in")=name of inv pt (no station #), 8 ; prcp("inv")=keep perpetual inventory flag 9 ; prcp("his")=keep detailed history flag, 10 ; prcp("i")=da of inv pt 11 ; 12 ;*83 Routine PRCPLO1 associated with PRC*5.1*83 is a modified copy of 13 ;this routine and any changes made to this routine should also be 14 ;considered for that routine as well. 15 ; 16 N %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y 17 I +$G(DUZ)<1 W !,"YOU ARE NOT SETUP AS A USER!" K PRC,PRCP Q 18 ; 19 S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q 20 I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q 21 ; 22 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q 23 I '% D DISPLAY Q 24 ; 25 ; allow adding new whse if not one for station 26 I $G(PRCP("DPTYPE"))="W" D Q:$G(PRCPFLAG) 27 . K PRCPFLAG 28 . S %=0 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I $P($P($G(^PRCP(445,%,0)),"^"),"-")=PRC("SITE") S PRCPFLAG=1 Q 29 . I $G(PRCPFLAG) K PRCPFLAG Q 30 . S PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"") 31 . I 'PRCP("I") S PRCPFLAG=1 K PRC,PRCP 32 ; 33 S %=$S($D(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^") 34 S (I,J)=0 35 F S I=$O(^PRCP(445,"AD",DUZ,I)) Q:'I I $D(^PRCP(445,I,0)) D I J>1 Q 36 . S:%="^"!(%[$P(^PRCP(445,I,0),"^",3)) Y(0)=^(0),J=J+1,Y=I 37 I J=1 D Q:$G(PRCPFLAG) S PRC("SITE")=+Y(0) D V1 Q 38 . I '$D(^PRC(411,+Y(0),0)) D K PRC,PRCP S PRCPFLAG=1 39 . . W !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE " 40 . . W +Y(0)," ARE MISSING." 41 I $G(PRCHAUTH) Q:'$G(PRCP("I")) D G V1 42 . S Y=PRCP("I")_"^"_$P($G(^PRCP(445,PRCP("I"),0)),U) 43 ; 44 S DIC="^PRCP(445,",DIC(0)="AEQMOZ" 45 S DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" 46 I $D(PRCP("DPTYPE")) S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)" 47 S DIC("A")="Select "_$S('$D(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: " 48 S D="C",PRCPPRIV=1 49 D IX^DIC 50 K PRCPPRIV,DIC 51 I Y<0 K PRC,PRCP Q 52 ; 53 V1 ; internal program jump 54 D PARAM(+Y) 55 ; 56 DISPLAY ; display top of page header 57 I '$G(PRCP("I")) G PRCPUSEL 58 S %=0 F I="RV1","RV0","XY" I '$D(PRCP(I)) S %=1 Q 59 I % D TERM 60 ; 61 S %="",$P(%," ",81)="" 62 S X="I N V E N T O R Y version "_$P($T(PRCPUSEL+1),";",3) 63 S Y=80-$L(X)\2 64 S X=$E(%,1,Y)_X_% 65 W @IOF,PRCP("RV1"),$E(X,1,40) 66 X PRCP("XY") 67 W $E(X,41,80),PRCP("RV0") 68 S PRCP("PAR")=^PRCP(445,PRCP("I"),0) 69 S X=$S(+$G(PRC("SITE")):"("_PRC("SITE")_") ",1:"") 70 S X=X_$S(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"") 71 S X=X_"Inventory Point: "_PRCP("IN") 72 W !,X,?(80-$L($P($G(PRC("PER")),"^",2))),$P($G(PRC("PER")),"^",2) 73 I PRCP("DPTYPE")="P" S Y=$P(PRCP("PAR"),"^",12) I Y,Y'>DT D 74 . D DD^%DT 75 . W !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"." 76 I $P(PRCP("PAR"),"^",9)="Y" D 77 . W !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL." 78 I $E($P(PRCP("PAR"),"^",14),1,5)'=$E(DT,1,5) D 79 . W !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED." 80 I $E($P(PRCP("PAR"),"^",17),1,5)'=$E(DT,1,5) D 81 . W !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED." 82 I PRCP("DPTYPE")'="S",$E($P(PRCP("PAR"),"^",19),1,5)'=$E(DT,1,5) D 83 . W !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED." 84 I $E($P(PRCP("PAR"),"^",18),1,5)'=$E(DT,1,5) D 85 . W !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED." 86 I $P(PRCP("PAR"),"^",6)="Y",$E($P(PRCP("PAR"),"^",22),1,5)'=$E(DT,1,5) D 87 . W !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET." 88 I PRCP("DPTYPE")="S",$P($G(^PRCP(445,PRCP("I"),5)),"^",1)]"" D SSMSG 89 I $O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),"")) D 90 . W !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS." 91 ; 92 W !,PRCP("RV1"),$E(%,1,40) X PRCP("XY") W $E(%,41,80),PRCP("RV0") 93 Q 94 ; 95 ; 96 NOMENU ; user did not select a valid inventory point, do not allow access 97 ; to the menu (called from option file) 98 N X 99 S X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU" D DISPLAY^PRCPUX2(1,79,.X) 100 Q 101 ; 102 ; 103 PARAM(INVPT) ; set up parameters for inventory point 104 K PRCP 105 N DATA 106 S DATA=$G(^PRCP(445,INVPT,0)) I DATA="" Q 107 S PRCP("I")=INVPT,PRCP("IN")=$P($P(DATA,"^"),"-",2,99),PRCP("INV")=$P(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3) 108 D TERM 109 Q 110 ; 111 ; 112 TERM ; get terminal attributes 113 N X 114 I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP 115 S X="IORVON;IORVOFF" D ENDR^%ZISS 116 S PRCP("RV1")=$G(IORVON),PRCP("RV0")=$G(IORVOFF) 117 S PRCP("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY")) 118 Q 119 ; 120 SSMSG ; check supply station secondaries, give message of qty mismatch 121 N GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT 122 S INVPT=PRCP("I") 123 S ITEM=0 124 F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q 125 . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item 126 . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7) 127 . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1) 128 . I 'GIPCNT,'SSCNT Q 129 . I GIPCNT=SSCNT Q 130 . W !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION." 131 . S PRCPFLAG=1
Note:
See TracChangeset
for help on using the changeset viewer.
