PSDGSK.m

PSDGSK ;BIR/CML,JPW-Build Sort Key for NAOUs in Inven. Grp ; 2 Aug 94

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)

 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S PSDT=Y K LN S $P(LN,"-",80)=""

DIC S DIC="^PSI(58.2,",DIC(0)="AEQ",DIC("A")="Select NAOU INVENTORY GROUP NAME: ",DIC("S")="I $D(^PSI(58.2,""CS"",+Y))" D ^DIC K DIC G:Y<0 END S INVGRP=+Y D PRINT

ASK1 R !!,"Make..... ",X:DTIME S:'$T X="^" G:"^"[X END I $E(X)="?" W !!,"Enter the name of the NAOU you wish to move to another location.",!,"Enter <RET> or ""^"" to EXIT." G ASK1

 S DIC="^PSI(58.2,"_INVGRP_",3,",DIC(0)="QEZ" D ^DIC K DIC G:Y<0 ASK1 S NAOUM=Y(0,0),NAOUDA=+Y

ASK2 R !,"Follow... ",X:DTIME S:'$T X="^" G:"^"[X END I $E(X)="?" W !!,"Enter the name of the NAOU you wish ",NAOUM," to follow.",!,"Enter <RET> or ""^"" to EXIT.",! G ASK2

 S DIC="^PSI(58.2,"_INVGRP_",3,",DIC(0)="QEZ",DIC("S")="I $P(^(0),""^"")'=NAOUDA" D ^DIC K DIC G:Y<0 ASK2

NEW S PSDSORT=$P(Y(0),"^",2),PSDSORTN=$O(^PSI(58.2,INVGRP,3,"D",PSDSORT)) I 'PSDSORTN S PSDNSORT=PSDSORT+50

 E  S PSDNSORT=PSDSORT+((PSDSORTN-PSDSORT)/2)

DIE S DIE="^PSI(58.2,",DA=INVGRP,DR="3///"_NAOUM,DR(2,58.29)="2///"_PSDNSORT D ^DIE I PSDNSORT["." D IGSET^PSDUTL

BOTTOM W !!,"Do you wish to print the NAOU 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,PSDFGRP,PSDNSORT,PSDSORT,PSDSORTN,A,DIC,DIE,DA,DR,DTOUT,X,Y,L,FLDS,BY,FR,TO,DIJ,DP,NAOUM,B,C,D,D0,D1,DI,DISYS,DQ,LN,PSDT,NAOUDA,POP,DHD

 Q

 ;

PRINT S L=0,DIC="^PSI(58.2,",FLDS="NARCOTIC,NARCOTIC",BY="'NUMBER@,NARCOTIC,SORT@",FR=INVGRP,TO=FR,DHD="W ?0 D HDR^PSDGSK" D EN1^DIP

 Q

HDR W !,"NAOU Inventory Group List",?60,PSDT,!!,"Current NAOU Sort Order for ",$P(^PSI(58.2,INVGRP,0),"^"),!,LN Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSDGSK   1857     printed  Apr 09, 2024@20:52:50                                                                                                                                                                                                      Page 2

PSDGSK    ;BIR/CML,JPW-Build Sort Key for NAOUs in Inven. Grp ; 2 Aug 94

 +1       ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 +2        IF '$DATA(PSDSITE)

               DO ^PSDSET

               if '$DATA(PSDSITE)

                   QUIT 

 +3        DO NOW^%DTC

           SET Y=+$EXTRACT(%,1,12)

           XECUTE ^DD("DD")

           SET PSDT=Y

           KILL LN

           SET $PIECE(LN,"-",80)=""

DIC        SET DIC="^PSI(58.2,"

           SET DIC(0)="AEQ"

           SET DIC("A")="Select NAOU INVENTORY GROUP NAME: "

           SET DIC("S")="I $D(^PSI(58.2,""CS"",+Y))"

           DO ^DIC

           KILL DIC

           if Y<0

               GOTO END

           SET INVGRP=+Y

           DO PRINT

ASK1       READ !!,"Make..... ",X:DTIME

           if '$TEST

               SET X="^"

           if "^"[X

               GOTO END

           IF $EXTRACT(X)="?"

               WRITE !!,"Enter the name of the NAOU you wish to move to another location.",!,"Enter <RET> or ""^"" to EXIT."

               GOTO ASK1

 +1        SET DIC="^PSI(58.2,"_INVGRP_",3,"

           SET DIC(0)="QEZ"

           DO ^DIC

           KILL DIC

           if Y<0

               GOTO ASK1

           SET NAOUM=Y(0,0)

           SET NAOUDA=+Y

ASK2       READ !,"Follow... ",X:DTIME

           if '$TEST

               SET X="^"

           if "^"[X

               GOTO END

           IF $EXTRACT(X)="?"

               WRITE !!,"Enter the name of the NAOU you wish ",NAOUM," to follow.",!,"Enter <RET> or ""^"" to EXIT.",!

               GOTO ASK2

 +1        SET DIC="^PSI(58.2,"_INVGRP_",3,"

           SET DIC(0)="QEZ"

           SET DIC("S")="I $P(^(0),""^"")'=NAOUDA"

           DO ^DIC

           KILL DIC

           if Y<0

               GOTO ASK2

NEW        SET PSDSORT=$PIECE(Y(0),"^",2)

           SET PSDSORTN=$ORDER(^PSI(58.2,INVGRP,3,"D",PSDSORT))

           IF 'PSDSORTN

               SET PSDNSORT=PSDSORT+50

 +1       IF '$TEST

               SET PSDNSORT=PSDSORT+((PSDSORTN-PSDSORT)/2)

DIE        SET DIE="^PSI(58.2,"

           SET DA=INVGRP

           SET DR="3///"_NAOUM

           SET DR(2,58.29)="2///"_PSDNSORT

           DO ^DIE

           IF PSDNSORT["."

               DO IGSET^PSDUTL

BOTTOM     WRITE !!,"Do you wish to print the NAOU 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,PSDFGRP,PSDNSORT,PSDSORT,PSDSORTN,A,DIC,DIE,DA,DR,DTOUT,X,Y,L,FLDS,BY,FR,TO,DIJ,DP,NAOUM,B,C,D,D0,D1,DI,DISYS,DQ,LN,PSDT,NAOUDA,POP,DHD

 +1        QUIT 

 +2       ;

PRINT      SET L=0

           SET DIC="^PSI(58.2,"

           SET FLDS="NARCOTIC,NARCOTIC"

           SET BY="'NUMBER@,NARCOTIC,SORT@"

           SET FR=INVGRP

           SET TO=FR

           SET DHD="W ?0 D HDR^PSDGSK"

           DO EN1^DIP

 +1        QUIT 

HDR        WRITE !,"NAOU Inventory Group List",?60,PSDT,!!,"Current NAOU Sort Order for ",$PIECE(^PSI(58.2,INVGRP,0),"^"),!,LN

           QUIT