source: FOIAVistA/trunk/r/AUTO_REPLENISHMENT_WARD_STOCK-PSGW/PSGWL.m@ 1765

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

initial load of FOIAVistA 6/30/08 version
File size: 3.5 KB
Line 
1PSGWL ;BHAM ISC/GRK,CML-Build AOU Inventory List ; 26 Nov 93 / 10:20 AM
2 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
3BAR S BARFLG=1 W !!,"This option will print a bar coded Inventory Sheet. In order to do so, you",!,"must queue the output to a printer that is properly set up to produce bar codes.",!
4ASKINV S (DIC,DLAYGO)=58.19,DIC(0)="QEAMLNZ",DIC("A")="SELECT DATE/TIME FOR INVENTORY: " D ^DIC K DIC,DLAYGO Q:Y<0 S PSGWIDA=+Y
5 I $P(^PSI(58.19,PSGWIDA,0),"^",4)'="" S PSGWGRP=$P(^(0),"^",4)
6 E S PSGWGRP=","
7 D ASKWIG G:X="^" OUT S $P(^PSI(58.19,PSGWIDA,0),"^",4)=$S($D(PSGWGRP)&(PSGWGRP'=","):PSGWGRP,1:"")
8INV I $P(^PSI(58.19,PSGWIDA,0),"^",4)'="" R !!,"Do you wish to print the AOU Inventory Sheet: YES// ",X:DTIME S:'$T X="^" S:X="" X="Y" G:(X="^")!("Nn"[$E(X)) OUT G ^PSGWPI:"yY"[$E(X) G:"yY"'[$E(X) HELP
9OUT K BARFLG,CHK,DIC,DIE,DR,GROUP,PSGD,PSGSORT,PSGWPGD,PSGISORT,PSGLSORT,PSGWDUP,PSGSW,PSGT,PSGW,PSGWN,PSGWIDA,PSGWGRP,Q,X,Y,AA,D1,DA,SKK,GRP,LP,PC,PSGWSK,PSGWSKP,PSGWS Q
10 ;
11ASKWIG R !!,"Select AOU INVENTORY GROUP: ",X:DTIME S:'$T X="^" Q:"^"[X I $E(X,1)="^" Q:X'="^AOU"
12 I X?."?" W !!,"AOU INVENTORY GROUPS currently chosen:",! F Q=2:1 S GROUP(Q)=$P(PSGWGRP,",",Q) W ! Q:GROUP(Q)="" W $P(^PSI(58.2,GROUP(Q),0),"^")
13 I $E(X,1,1)'="^" D WIG,WIBLD:Y'<0 S:PSGD'<0 PSGWPGD=PSGD D GRPNAME:PSGD'<0 G ASKWIG
14 ;
15 S:'$D(PSGSORT) PSGSORT=0 S DA=PSGWIDA,DR=".5",DR(2,58.24)="1",DIE="^PSI(58.19," D ^DIE G:$D(Y) ASKWIG S:$D(DA) PSGW=DA S PSGSORT=PSGSORT+100 D DUPAOU,XREF K DR G ASKWIG
16 ;
17WIG K PSGSW I $E(X,1)="-" S X=$E(X,2,999),PSGSW=""
18 S DIC("DR")="[PSGW WARD INVENTORY]",DIC="^PSI(58.2,",DIC(0)="QEMZ",DIC("S")="I $D(^PSI(58.2,""WS"",+Y))" D ^DIC K DIC S PSGD=+Y
19 I '$D(PSGSW) S CHK=","_PSGD_"," I PSGWGRP[CHK W *7,!!,"** This AOU INVENTORY GROUP has already been selected **" S (PSGD,Y)=-1
20 Q
21 ;
22WIBLD W ! F PSGSORT=0:0 S PSGSORT=$O(^PSI(58.2,PSGD,1,"D",PSGSORT)) Q:'PSGSORT S PSGW=$O(^PSI(58.2,PSGD,1,"D",PSGSORT,0)) D WID,WSTUF:$D(PSGSW) I '$D(PSGSW) D DUPAOU F PSGT=0:0 S PSGT=$O(^PSI(58.2,PSGD,1,PSGW,1,PSGT)) Q:'PSGT D WSTUF
23 W $S($D(PSGSW):"Deleted",1:"Added") Q
24 ;
25GRPNAME I '$D(PSGSW) S PSGWGRP=PSGWGRP_PSGD_"," Q
26 I PSGWGRP[PSGD S PSGWGRP=$P(PSGWGRP,","_PSGD_",",1)_","_$P(PSGWGRP,","_PSGD_",",2,99)
27 Q
28 ;
29WID S PSGWN=$S($D(^PSI(58.1,PSGW,0)):$P(^(0),"^",1),1:"") W PSGWN," "
30 Q
31 ;
32WSTUF S DA=PSGWIDA,DIE="^PSI(58.19,"
33 I $D(PSGSW) Q:'$D(^PSI(58.19,DA,1,PSGW,0)) S DR=".5///"_PSGWN,DR(2,58.24)=".01///@" D ^DIE K DR Q
34 I '$D(^PSI(58.19,PSGWIDA,1,PSGW,0)) D ADDAOU S ^PSI(58.19,PSGWIDA,1,PSGW,0)=PSGW_"^"_PSGISORT
35 I '$D(^PSI(58.19,PSGWIDA,1,PSGW,1,PSGT,0)) D ADDTYPE S ^PSI(58.19,PSGWIDA,1,PSGW,1,PSGT,0)=PSGT
36XREF I '$D(^PSI(58.19,PSGWIDA,1,"B",PSGW,PSGW)) S ^(PSGW)=""
37 I 'PSGWDUP,'$D(^PSI(58.19,PSGWIDA,1,"C",PSGISORT,PSGW)) S ^(PSGW)=""
38 Q
39ADDAOU I '$D(^PSI(58.19,PSGWIDA,1,0)) S ^(0)="^58.24PA^"_PSGW_"^1"
40 E S (^(0))=$P(^PSI(58.19,PSGWIDA,1,0),"^",1,2)_"^"_$S($P(^(0),"^",3)<PSGW:PSGW,1:$P(^(0),"^",3))_"^"_($P(^(0),"^",4)+1)
41 Q
42ADDTYPE I '$D(^PSI(58.19,PSGWIDA,1,PSGW,1,0)) S ^(0)="^58.25PA^"_PSGT_"^1"
43 E S (^(0))=$P(^PSI(58.19,PSGWIDA,1,PSGW,1,0),"^",1,2)_"^"_$S($P(^(0),"^",3)<PSGT:PSGT,1:$P(^(0),"^",3))_"^"_($P(^(0),"^",4)+1)
44 Q
45DUPAOU S PSGWDUP=0 F SKK=0:0 S SKK=$O(^PSI(58.19,PSGWIDA,1,"C",SKK)) Q:'SKK F AA=0:0 S AA=$O(^PSI(58.19,PSGWIDA,1,"C",SKK,AA)) Q:'AA I AA=PSGW S PSGWDUP=1 Q
46SORTCK Q:PSGWDUP I $D(PSGWPGD),(PSGWPGD'=PSGD) S PSGISORT=PSGLSORT+100
47 E S PSGISORT=PSGSORT
48 S PSGLSORT=PSGISORT
49 K SKK,AA
50 Q
51 ;
52HELP W *7,*7,!!,"Enter ""N"" or ""NO"", or press <RET> to accept the default answer." G INV
Note: See TracBrowser for help on using the repository browser.