PSGWL ;BHAM ISC/GRK,CML-Build AOU Inventory List ; 26 Nov 93 / 10:20 AM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
BAR 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.",!
ASKINV 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
I $P(^PSI(58.19,PSGWIDA,0),"^",4)'="" S PSGWGRP=$P(^(0),"^",4)
E S PSGWGRP=","
D ASKWIG G:X="^" OUT S $P(^PSI(58.19,PSGWIDA,0),"^",4)=$S($D(PSGWGRP)&(PSGWGRP'=","):PSGWGRP,1:"")
INV 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
OUT 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
;
ASKWIG R !!,"Select AOU INVENTORY GROUP: ",X:DTIME S:'$T X="^" Q:"^"[X I $E(X,1)="^" Q:X'="^AOU"
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),"^")
I $E(X,1,1)'="^" D WIG,WIBLD:Y'<0 S:PSGD'<0 PSGWPGD=PSGD D GRPNAME:PSGD'<0 G ASKWIG
;
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
;
WIG K PSGSW I $E(X,1)="-" S X=$E(X,2,999),PSGSW=""
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
I '$D(PSGSW) S CHK=","_PSGD_"," I PSGWGRP[CHK W *7,!!,"** This AOU INVENTORY GROUP has already been selected **" S (PSGD,Y)=-1
Q
;
WIBLD 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
W $S($D(PSGSW):"Deleted",1:"Added") Q
;
GRPNAME I '$D(PSGSW) S PSGWGRP=PSGWGRP_PSGD_"," Q
I PSGWGRP[PSGD S PSGWGRP=$P(PSGWGRP,","_PSGD_",",1)_","_$P(PSGWGRP,","_PSGD_",",2,99)
Q
;
WID S PSGWN=$S($D(^PSI(58.1,PSGW,0)):$P(^(0),"^",1),1:"") W PSGWN," "
Q
;
WSTUF S DA=PSGWIDA,DIE="^PSI(58.19,"
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
I '$D(^PSI(58.19,PSGWIDA,1,PSGW,0)) D ADDAOU S ^PSI(58.19,PSGWIDA,1,PSGW,0)=PSGW_"^"_PSGISORT
I '$D(^PSI(58.19,PSGWIDA,1,PSGW,1,PSGT,0)) D ADDTYPE S ^PSI(58.19,PSGWIDA,1,PSGW,1,PSGT,0)=PSGT
XREF I '$D(^PSI(58.19,PSGWIDA,1,"B",PSGW,PSGW)) S ^(PSGW)=""
I 'PSGWDUP,'$D(^PSI(58.19,PSGWIDA,1,"C",PSGISORT,PSGW)) S ^(PSGW)=""
Q
ADDAOU I '$D(^PSI(58.19,PSGWIDA,1,0)) S ^(0)="^58.24PA^"_PSGW_"^1"
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)
Q
ADDTYPE I '$D(^PSI(58.19,PSGWIDA,1,PSGW,1,0)) S ^(0)="^58.25PA^"_PSGT_"^1"
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)
Q
DUPAOU 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
SORTCK Q:PSGWDUP I $D(PSGWPGD),(PSGWPGD'=PSGD) S PSGISORT=PSGLSORT+100
E S PSGISORT=PSGSORT
S PSGLSORT=PSGISORT
K SKK,AA
Q
;
HELP W *7,*7,!!,"Enter ""N"" or ""NO"", or press <RET> to accept the default answer." G INV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWL 3611 printed Nov 22, 2024@16:49:44 Page 2
PSGWL ;BHAM ISC/GRK,CML-Build AOU Inventory List ; 26 Nov 93 / 10:20 AM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
BAR SET BARFLG=1
WRITE !!,"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.",!
ASKINV SET (DIC,DLAYGO)=58.19
SET DIC(0)="QEAMLNZ"
SET DIC("A")="SELECT DATE/TIME FOR INVENTORY: "
DO ^DIC
KILL DIC,DLAYGO
if Y<0
QUIT
SET PSGWIDA=+Y
+1 IF $PIECE(^PSI(58.19,PSGWIDA,0),"^",4)'=""
SET PSGWGRP=$PIECE(^(0),"^",4)
+2 IF '$TEST
SET PSGWGRP=","
+3 DO ASKWIG
if X="^"
GOTO OUT
SET $PIECE(^PSI(58.19,PSGWIDA,0),"^",4)=$SELECT($DATA(PSGWGRP)&(PSGWGRP'=","):PSGWGRP,1:"")
INV IF $PIECE(^PSI(58.19,PSGWIDA,0),"^",4)'=""
READ !!,"Do you wish to print the AOU Inventory Sheet: YES// ",X:DTIME
if '$TEST
SET X="^"
if X=""
SET X="Y"
if (X="^")!("Nn"[$EXTRACT(X))
GOTO OUT
if "yY"[$EXTRACT(X)
GOTO ^PSGWPI
if "yY"'[$EXTRACT(X)
GOTO HELP
OUT KILL 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
QUIT
+1 ;
ASKWIG READ !!,"Select AOU INVENTORY GROUP: ",X:DTIME
if '$TEST
SET X="^"
if "^"[X
QUIT
IF $EXTRACT(X,1)="^"
if X'="^AOU"
QUIT
+1 IF X?."?"
WRITE !!,"AOU INVENTORY GROUPS currently chosen:",!
FOR Q=2:1
SET GROUP(Q)=$PIECE(PSGWGRP,",",Q)
WRITE !
if GROUP(Q)=""
QUIT
WRITE $PIECE(^PSI(58.2,GROUP(Q),0),"^")
+2 IF $EXTRACT(X,1,1)'="^"
DO WIG
if Y'<0
DO WIBLD
if PSGD'<0
SET PSGWPGD=PSGD
if PSGD'<0
DO GRPNAME
GOTO ASKWIG
+3 ;
+4 if '$DATA(PSGSORT)
SET PSGSORT=0
SET DA=PSGWIDA
SET DR=".5"
SET DR(2,58.24)="1"
SET DIE="^PSI(58.19,"
DO ^DIE
if $DATA(Y)
GOTO ASKWIG
if $DATA(DA)
SET PSGW=DA
SET PSGSORT=PSGSORT+100
DO DUPAOU
DO XREF
KILL DR
GOTO ASKWIG
+5 ;
WIG KILL PSGSW
IF $EXTRACT(X,1)="-"
SET X=$EXTRACT(X,2,999)
SET PSGSW=""
+1 SET DIC("DR")="[PSGW WARD INVENTORY]"
SET DIC="^PSI(58.2,"
SET DIC(0)="QEMZ"
SET DIC("S")="I $D(^PSI(58.2,""WS"",+Y))"
DO ^DIC
KILL DIC
SET PSGD=+Y
+2 IF '$DATA(PSGSW)
SET CHK=","_PSGD_","
IF PSGWGRP[CHK
WRITE *7,!!,"** This AOU INVENTORY GROUP has already been selected **"
SET (PSGD,Y)=-1
+3 QUIT
+4 ;
WIBLD WRITE !
FOR PSGSORT=0:0
SET PSGSORT=$ORDER(^PSI(58.2,PSGD,1,"D",PSGSORT))
if 'PSGSORT
QUIT
SET PSGW=$ORDER(^PSI(58.2,PSGD,1,"D",PSGSORT,0))
DO WID
if $DATA(PSGSW)
DO WSTUF
IF '$DATA(PSGSW)
DO DUPAOU
FOR PSGT=0:0
SET PSGT=$ORDER(^PSI(58.2,PSGD,1,PSGW,1,PSGT))
if 'PSGT
QUIT
DO WSTUF
+1 WRITE $SELECT($DATA(PSGSW):"Deleted",1:"Added")
QUIT
+2 ;
GRPNAME IF '$DATA(PSGSW)
SET PSGWGRP=PSGWGRP_PSGD_","
QUIT
+1 IF PSGWGRP[PSGD
SET PSGWGRP=$PIECE(PSGWGRP,","_PSGD_",",1)_","_$PIECE(PSGWGRP,","_PSGD_",",2,99)
+2 QUIT
+3 ;
WID SET PSGWN=$SELECT($DATA(^PSI(58.1,PSGW,0)):$PIECE(^(0),"^",1),1:"")
WRITE PSGWN," "
+1 QUIT
+2 ;
WSTUF SET DA=PSGWIDA
SET DIE="^PSI(58.19,"
+1 IF $DATA(PSGSW)
if '$DATA(^PSI(58.19,DA,1,PSGW,0))
QUIT
SET DR=".5///"_PSGWN
SET DR(2,58.24)=".01///@"
DO ^DIE
KILL DR
QUIT
+2 IF '$DATA(^PSI(58.19,PSGWIDA,1,PSGW,0))
DO ADDAOU
SET ^PSI(58.19,PSGWIDA,1,PSGW,0)=PSGW_"^"_PSGISORT
+3 IF '$DATA(^PSI(58.19,PSGWIDA,1,PSGW,1,PSGT,0))
DO ADDTYPE
SET ^PSI(58.19,PSGWIDA,1,PSGW,1,PSGT,0)=PSGT
XREF IF '$DATA(^PSI(58.19,PSGWIDA,1,"B",PSGW,PSGW))
SET ^(PSGW)=""
+1 IF 'PSGWDUP
IF '$DATA(^PSI(58.19,PSGWIDA,1,"C",PSGISORT,PSGW))
SET ^(PSGW)=""
+2 QUIT
ADDAOU IF '$DATA(^PSI(58.19,PSGWIDA,1,0))
SET ^(0)="^58.24PA^"_PSGW_"^1"
+1 IF '$TEST
SET (^(0))=$PIECE(^PSI(58.19,PSGWIDA,1,0),"^",1,2)_"^"_$SELECT($PIECE(^(0),"^",3)<PSGW:PSGW,1:$PIECE(^(0),"^",3))_"^"_($PIECE(^(0),"^",4)+1)
+2 QUIT
ADDTYPE IF '$DATA(^PSI(58.19,PSGWIDA,1,PSGW,1,0))
SET ^(0)="^58.25PA^"_PSGT_"^1"
+1 IF '$TEST
SET (^(0))=$PIECE(^PSI(58.19,PSGWIDA,1,PSGW,1,0),"^",1,2)_"^"_$SELECT($PIECE(^(0),"^",3)<PSGT:PSGT,1:$PIECE(^(0),"^",3))_"^"_($PIECE(^(0),"^",4)+1)
+2 QUIT
DUPAOU SET PSGWDUP=0
FOR SKK=0:0
SET SKK=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SKK))
if 'SKK
QUIT
FOR AA=0:0
SET AA=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SKK,AA))
if 'AA
QUIT
IF AA=PSGW
SET PSGWDUP=1
QUIT
SORTCK if PSGWDUP
QUIT
IF $DATA(PSGWPGD)
IF (PSGWPGD'=PSGD)
SET PSGISORT=PSGLSORT+100
+1 IF '$TEST
SET PSGISORT=PSGSORT
+2 SET PSGLSORT=PSGISORT
+3 KILL SKK,AA
+4 QUIT
+5 ;
HELP WRITE *7,*7,!!,"Enter ""N"" or ""NO"", or press <RET> to accept the default answer."
GOTO INV
