- 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 Mar 13, 2025@20:44:11 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
