- PSGWSIG ;BHAM ISC/CML-Build Sort Key for AOUs in Inventory Group ; 17 Aug 93 / 12:58 PM
- ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- S PSGWDT=$$PSGWDT^PSGWUTL1 S $P(LN,"-",80)=""
- DIC S DIC="^PSI(58.2,",DIC(0)="AEQM",DIC("S")="I $D(^PSI(58.2,""WS"",+Y))" D ^DIC K DIC G:Y<0 END S INVGRP=+Y D PRINT G:POP END
- ASK1 R !!,"Make..... ",X:DTIME S:'$T X="^" G:"^"[X END I $E(X)="?" W !!,"Enter the name of the AOU you wish to move to another location.",!,"Enter <RETURN> or ""^"" to Exit." G ASK1
- S DIC="^PSI(58.2,"_INVGRP_",1,",DIC(0)="QEMZ" D ^DIC K DIC G:Y<0 ASK1 S AOUM=Y(0,0),AOUDA=+Y
- ASK2 R !,"Follow... ",X:DTIME S:'$T X="^" G:"^"[X END I $E(X)="?" W !!,"Enter the name of the AOU you wish ",AOUM," to follow.",!,"Enter <RETURN> or ""^"" to Exit.",! G ASK2
- S DIC="^PSI(58.2,"_INVGRP_",1,",DIC(0)="QEMZ",DIC("S")="I $P(^(0),""^"")'=AOUDA" D ^DIC K DIC G:Y<0 ASK2
- NEW S PSGSORT=$P(Y(0),"^",2),PSGSORTN=$O(^PSI(58.2,INVGRP,1,"D",PSGSORT)) I PSGSORTN'>0 S PSGNSORT=PSGSORT+50
- E S PSGNSORT=PSGSORT+((PSGSORTN-PSGSORT)/2)
- DIE S DIE="^PSI(58.2,",DA=INVGRP,DR="1///"_AOUM,DR(2,58.21)="2///"_PSGNSORT D ^DIE I PSGNSORT["." D IGSET^PSGWUTL1
- BOTTOM W !!,"Do you wish to print the AOU List again " S %=2 D YN^DICN I %=0 W !?5,"Enter 'YES' if you wish to see the current AOU sort order for ",!?5,$P(^PSI(58.2,INVGRP,0),"^") G BOTTOM
- D:%=1 PRINT G ASK1
- END K %,%H,%I,%Y,INVGRP,PSGFGRP,PSGNSORT,PSGSORT,PSGSORTN,A,DIC,DIE,DA,DR,X,Y,L,FLDS,BY,FR,TO,DIJ,DP,AOUM,B,C,D,D0,D1,DI,DISYS,DQ,LN,PSGWDT,AOUDA
- Q
- ;
- PRINT S L=0,DIC="^PSI(58.2,",FLDS="AREA,AREA",BY="'NUMBER@,AREA,SORT@",FR=INVGRP,TO=FR,DHD="W ?0 D HDR^PSGWSIG" D EN1^DIP Q
- HDR W !,"AOU Inventory Group List",?60,PSGWDT,!!,"Current AOU Sort Order for ",$P(^PSI(58.2,INVGRP,0),"^"),!,LN Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWSIG 1761 printed Feb 18, 2025@23:06:31 Page 2
- PSGWSIG ;BHAM ISC/CML-Build Sort Key for AOUs in Inventory Group ; 17 Aug 93 / 12:58 PM
- +1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- +2 SET PSGWDT=$$PSGWDT^PSGWUTL1
- SET $PIECE(LN,"-",80)=""
- DIC SET DIC="^PSI(58.2,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $D(^PSI(58.2,""WS"",+Y))"
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- SET INVGRP=+Y
- DO PRINT
- if POP
- GOTO END
- ASK1 READ !!,"Make..... ",X:DTIME
- if '$TEST
- SET X="^"
- if "^"[X
- GOTO END
- IF $EXTRACT(X)="?"
- WRITE !!,"Enter the name of the AOU you wish to move to another location.",!,"Enter <RETURN> or ""^"" to Exit."
- GOTO ASK1
- +1 SET DIC="^PSI(58.2,"_INVGRP_",1,"
- SET DIC(0)="QEMZ"
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO ASK1
- SET AOUM=Y(0,0)
- SET AOUDA=+Y
- ASK2 READ !,"Follow... ",X:DTIME
- if '$TEST
- SET X="^"
- if "^"[X
- GOTO END
- IF $EXTRACT(X)="?"
- WRITE !!,"Enter the name of the AOU you wish ",AOUM," to follow.",!,"Enter <RETURN> or ""^"" to Exit.",!
- GOTO ASK2
- +1 SET DIC="^PSI(58.2,"_INVGRP_",1,"
- SET DIC(0)="QEMZ"
- SET DIC("S")="I $P(^(0),""^"")'=AOUDA"
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO ASK2
- NEW SET PSGSORT=$PIECE(Y(0),"^",2)
- SET PSGSORTN=$ORDER(^PSI(58.2,INVGRP,1,"D",PSGSORT))
- IF PSGSORTN'>0
- SET PSGNSORT=PSGSORT+50
- +1 IF '$TEST
- SET PSGNSORT=PSGSORT+((PSGSORTN-PSGSORT)/2)
- DIE SET DIE="^PSI(58.2,"
- SET DA=INVGRP
- SET DR="1///"_AOUM
- SET DR(2,58.21)="2///"_PSGNSORT
- DO ^DIE
- IF PSGNSORT["."
- DO IGSET^PSGWUTL1
- BOTTOM WRITE !!,"Do you wish to print the AOU List again "
- SET %=2
- DO YN^DICN
- IF %=0
- WRITE !?5,"Enter 'YES' if you wish to see the current AOU sort order for ",!?5,$PIECE(^PSI(58.2,INVGRP,0),"^")
- GOTO BOTTOM
- +1 if %=1
- DO PRINT
- GOTO ASK1
- END KILL %,%H,%I,%Y,INVGRP,PSGFGRP,PSGNSORT,PSGSORT,PSGSORTN,A,DIC,DIE,DA,DR,X,Y,L,FLDS,BY,FR,TO,DIJ,DP,AOUM,B,C,D,D0,D1,DI,DISYS,DQ,LN,PSGWDT,AOUDA
- +1 QUIT
- +2 ;
- PRINT SET L=0
- SET DIC="^PSI(58.2,"
- SET FLDS="AREA,AREA"
- SET BY="'NUMBER@,AREA,SORT@"
- SET FR=INVGRP
- SET TO=FR
- SET DHD="W ?0 D HDR^PSGWSIG"
- DO EN1^DIP
- QUIT
- HDR WRITE !,"AOU Inventory Group List",?60,PSGWDT,!!,"Current AOU Sort Order for ",$PIECE(^PSI(58.2,INVGRP,0),"^"),!,LN
- QUIT
