PSGWTR.m

PSGWTR ;BHAM ISC/PTD,CML-Transfer Stock Entries from One AOU to Another ; 08 Dec 93 / 10:02 AM

 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94

 K LOC("TR") S CT=0,PSGWDUZ=DUZ W !!,"This option will copy the stock entries from one AOU into AOUs",!,"you select.  Inactive or duplicate items will not be transferred."

 W !,"Choosing to copy stock items into multiple AOUs will allow you",!,"to choose up to 10 AOUs at one time."

HOWMANY W !!?5,"Do you wish to copy stock items INTO:",!?5,"(1) ONE Area of Use, or",!?5,"(2) multiple Areas of Use",!!,"Select ""1"" or ""2"": " R CHS:DTIME

 G:'$T!("^"[CHS) END I CHS=1!(CHS=2) G WHAT

 W !!,"Answer ""1"" if transfer to only ONE AOU is desired,",!,"answer ""2"" if the same stock list is to be copied into more than one AOU." G HOWMANY

 ;

WHAT W !!?5,"Do you wish to transfer:",!?5,"(1) Drug (item) name only, or",!?5,"(2) Drug name, stock level, and location, or",!?5,"(3) Drug name, stock level, location, and type.",!!,"Select ""1"", ""2"", or ""3"": " R TR:DTIME

 G:'$T!("^"[TR) END I TR=1!(TR=2)!(TR=3) G DICF

 W !!,"Answer ""1"" if transfer of ONLY drug name is desired,",!,"answer ""2"" if you wish to copy drug name, stock level, and location, or",!,"answer ""3"" if you wish to transfer drug name, stock level, location, and types." G WHAT

 ;

DICF W ! S DIC="^PSI(58.1,",DIC(0)="QEAM",DIC("A")="Select AOU to transfer stock list FROM: " D ^DIC K DIC G:Y<0 END S AOUF=+Y W !

 ;

DICT S DIC="^PSI(58.1,",DIC(0)="QEAM",DIC("A")="Select AOU to transfer stock list INTO: " D ^DIC K DIC G:(Y<0)&(CHS=1) END G:(Y<0)&(CHS=2) SURE S LOC("TR",+Y)="",CT=CT+1 G:CT>9 LIMIT G:CHS=2 DICT

 ;

SURE I $D(LOC("TR",AOUF)) W *7,*7,!!?5,"NOT ALLOWED to transfer out of and into SAME Area of Use!" G END

 G:'$O(LOC("TR",0)) END W !!?5,"I will now COPY the ENTIRE stock list from",!?5,$P(^PSI(58.1,AOUF,0),"^")," into" F J=0:0 S J=$O(LOC("TR",J)) Q:'J  W !?5,$P(^PSI(58.1,J,0),"^")

 W !!?5,"I will transfer ",$S(TR=2:"drug name, stock level, and location.",TR=3:"drug name, stock level, location, and types.",1:"drug name only.")

 R !!,"Are you SURE that is what you want to do?  NO// ",X:DTIME

 G:'$T!("^Nn"[$E(X)) END I "YyNn"'[$E(X) W *7,!!,"Answer ""yes"" if you wish to transfer stock entries.",!,"Answer ""no"" or <return> if you do not.",!! G SURE

 ;

QUE W !!,"This job will automatically be queued to run in the background.",!,"You will be notified by MailMan when the transfer is completed.",!

 S AOUT="" F J=0:0 S J=$O(LOC("TR",J)) Q:'J  S AOUT=AOUT_J_","

 S ZTIO="",ZTDTH=$H,ZTRTN="^PSGWTR1",ZTDESC="Transfer AOU Stock" F G="AOUF","TR","PSGWDUZ","AOUT" S:$D(@G) ZTSAVE(G)=""

 D ^%ZTLOAD,HOME^%ZIS W !,"TRANSFER FILE ENTRIES queued!"

END K AOUF,CHS,J,TR,X,G,ZTIO,AOUT,CT,PSGWDUZ,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,LOC("TR"),ZTSK

 S:$D(ZTQUEUED) ZTREQ="@" Q

 ;

LIMIT W !!,"You may not transfer TO additional AOUs at this time.",!,"Enter the option again to transfer to more AOUs." G SURE

PSGWTR    ;BHAM ISC/PTD,CML-Transfer Stock Entries from One AOU to Another ; 08 Dec 93 / 10:02 AM

 +1       ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94

 +2        KILL LOC("TR")

           SET CT=0

           SET PSGWDUZ=DUZ

           WRITE !!,"This option will copy the stock entries from one AOU into AOUs",!,"you select.  Inactive or duplicate items will not be transferred."

 +3        WRITE !,"Choosing to copy stock items into multiple AOUs will allow you",!,"to choose up to 10 AOUs at one time."

HOWMANY    WRITE !!?5,"Do you wish to copy stock items INTO:",!?5,"(1) ONE Area of Use, or",!?5,"(2) multiple Areas of Use",!!,"Select ""1"" or ""2"": "

           READ CHS:DTIME

 +1        IF '$TEST!("^"[CHS)

               GOTO END

           IF CHS=1!(CHS=2)

               GOTO WHAT

 +2        WRITE !!,"Answer ""1"" if transfer to only ONE AOU is desired,",!,"answer ""2"" if the same stock list is to be copied into more than one AOU."

           GOTO HOWMANY

 +3       ;

WHAT       WRITE !!?5,"Do you wish to transfer:",!?5,"(1) Drug (item) name only, or",!?5,"(2) Drug name, stock level, and location, or",!?5,"(3) Drug name, stock level, location, and type.",!!,"Select ""1"", ""2"", or ""3"": "

           READ TR:DTIME

 +1        IF '$TEST!("^"[TR)

               GOTO END

           IF TR=1!(TR=2)!(TR=3)

               GOTO DICF

 +2        WRITE !!,"Answer ""1"" if transfer of ONLY drug name is desired,",!,"answer ""2"" if you wish to copy drug name, stock level, and location, or",!,"answer ""3"" if you wish to transfer drug name, stock level, location, and types."

           GOTO WHAT

 +3       ;

DICF       WRITE !

           SET DIC="^PSI(58.1,"

           SET DIC(0)="QEAM"

           SET DIC("A")="Select AOU to transfer stock list FROM: "

           DO ^DIC

           KILL DIC

           IF Y<0

               GOTO END

           SET AOUF=+Y

           WRITE !

 +1       ;

DICT       SET DIC="^PSI(58.1,"

           SET DIC(0)="QEAM"

           SET DIC("A")="Select AOU to transfer stock list INTO: "

           DO ^DIC

           KILL DIC

           IF (Y<0)&(CHS=1)

               GOTO END

           IF (Y<0)&(CHS=2)

               GOTO SURE

           SET LOC("TR",+Y)=""

           SET CT=CT+1

           IF CT>9

               GOTO LIMIT

           IF CHS=2

               GOTO DICT

 +1       ;

SURE       IF $DATA(LOC("TR",AOUF))

               WRITE *7,*7,!!?5,"NOT ALLOWED to transfer out of and into SAME Area of Use!"

               GOTO END

 +1        IF '$ORDER(LOC("TR",0))

               GOTO END

           WRITE !!?5,"I will now COPY the ENTIRE stock list from",!?5,$PIECE(^PSI(58.1,AOUF,0),"^")," into"

           FOR J=0:0

               SET J=$ORDER(LOC("TR",J))

               IF 'J

                   QUIT 

               WRITE !?5,$PIECE(^PSI(58.1,J,0),"^")

 +2        WRITE !!?5,"I will transfer ",$SELECT(TR=2:"drug name, stock level, and location.",TR=3:"drug name, stock level, location, and types.",1:"drug name only.")

 +3        READ !!,"Are you SURE that is what you want to do?  NO// ",X:DTIME

 +4        IF '$TEST!("^Nn"[$EXTRACT(X))

               GOTO END

           IF "YyNn"'[$EXTRACT(X)

               WRITE *7,!!,"Answer ""yes"" if you wish to transfer stock entries.",!,"Answer ""no"" or <return> if you do not.",!!

               GOTO SURE

 +5       ;

QUE        WRITE !!,"This job will automatically be queued to run in the background.",!,"You will be notified by MailMan when the transfer is completed.",!

 +1        SET AOUT=""

           FOR J=0:0

               SET J=$ORDER(LOC("TR",J))

               IF 'J

                   QUIT 

               SET AOUT=AOUT_J_","

 +2        SET ZTIO=""

           SET ZTDTH=$HOROLOG

           SET ZTRTN="^PSGWTR1"

           SET ZTDESC="Transfer AOU Stock"

           FOR G="AOUF","TR","PSGWDUZ","AOUT"

               IF $DATA(@G)

                   SET ZTSAVE(G)=""

 +3        DO ^%ZTLOAD

           DO HOME^%ZIS

           WRITE !,"TRANSFER FILE ENTRIES queued!"

END        KILL AOUF,CHS,J,TR,X,G,ZTIO,AOUT,CT,PSGWDUZ,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,LOC("TR"),ZTSK

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           QUIT 

 +2       ;

LIMIT      WRITE !!,"You may not transfer TO additional AOUs at this time.",!,"Enter the option again to transfer to more AOUs."

           GOTO SURE