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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWTR 2954 printed Dec 13, 2024@01:40:13 Page 2
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
