- PSDTRA ;BIR/JPW-Transfer Stock Entries from AOU to NAOU ; 18 July 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
- K LOC("TR") S CNT=0,PSDUZ=DUZ
- W !!,"This option will copy the stock entries from one AR/WS AOU into NAOUs you ",!,"select. No more than 10 transfers are allowed at a time.",!,"Inactive drugs will not be transferred.",!
- NUM ;ask how many NAOUs
- W ! K DA,DIR,DIRUT S DIR(0)="SO^1:Transfer to one NAOU;2:Transfer to multiple NAOUs",DIR("A")="Select Transfer Type"
- S DIR("?",1)="Answer '1' if transfer to only ONE NAOU is desired, '2' if the same",DIR("?")="stock list is to be copied into more than one NAOU, or '^' to quit."
- D ^DIR K DIR G:$D(DIRUT) END S ANS=+Y
- METHOD ;asks method of stock transfer
- W !!!,"=> Methods of transferring stock drug data."
- W ! K DA,DIR,DIRUT S DIR(0)="SO^1:Drug name only;2:Drug name, stock level, and location code;3:Drug name, stock level, location code, and inv. types",DIR("A")="Select Transfer Method"
- S DIR("?",1)="Answer '1' if transfer of ONLY drug name is desired, '2' if you wish to",DIR("?",2)="copy drug name, stock level, and location code, '3' if you wish to transfer"
- S DIR("?")="drug name, stock level, location code, and inv. type, or '^' to quit."
- D ^DIR K DIR G:$D(DIRUT) END S MTR=+Y
- FROM ;select AR/WS AOU to transfer stock from
- W ! K DA,DIC S DIC=58.1,DIC(0)="QEA",DIC("A")="Select AR/WS AOU to transfer drug stock FROM: " D ^DIC K DIC G:Y<0 END S AOU=+Y
- TO ;select NAOU(s) to transfer stock to
- W ! K DA,DIC S DIC=58.8,DIC(0)="QEA",DIC("A")="Select NAOU to transfer drug stock INTO: ",DIC("S")="I $P(^(0),""^"",2)'=""P"",$P(^(0),""^"",3)=+PSDSITE"
- D ^DIC K DIC G:(Y<0)&(ANS=1) END G:(Y<0)&(ANS=2) CHK S LOC("TR",+Y)="",CNT=CNT+1
- I CNT>9 W !!,"You may not transfer TO additional NAOUs at this time.",!,"Enter the option again to transfer to more NAOUs.",!
- I ANS=2,CNT<10 G TO
- CHK ;checks for valid NAOUs
- G:'$O(LOC("TR",0)) END
- W !!,?5,"I will now COPY the ENTIRE drug stock list from ",!,?5,$P(^PSI(58.1,AOU,0),"^")," into" F TR=0:0 S TR=$O(LOC("TR",TR)) Q:'TR W !,?5,$P(^PSD(58.8,TR,0),"^")
- W !!,?5,"I will transfer ",$S(MTR=3:"drug name, stock level, location code and types.",MTR=2:"drug name, stock level and location code.",1:"drug name only.")
- W !! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure that is what you want to do"
- S DIR("?",1)="Answer 'YES' if you wish to transfer stock entries,",DIR("?")="answer 'NO' or <RET> if you do not."
- D ^DIR K DIR I 'Y!$D(DIRUT) G END
- QUE W !!,"This job will automatically be queued to run in the background.",!,"You'll be notified by a MailMan message when the transfer is completed.",!
- S NAOUT="" F TR=0:0 S TR=$O(LOC("TR",TR)) Q:'TR S NAOUT=NAOUT_TR_","
- S ZTIO="",ZTDTH=$H,ZTRTN="^PSDTRA1",ZTDESC="Transfer AR/WS Stock to NAOU" S (ZTSAVE("MTR"),ZTSAVE("NAOUT"),ZTSAVE("AOU"),ZTSAVE("PSDUZ"))=""
- D ^%ZTLOAD W !!,"Transfer AR/WS Stock Drugs to NAOU has been queued.",!
- END K ANS,AOU,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LOC,MTR,NAOUT,PSDUZ,TR,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- S:$D(ZTQUEUED) ZTREQ="@"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDTRA 3139 printed Jan 18, 2025@02:50:19 Page 2
- PSDTRA ;BIR/JPW-Transfer Stock Entries from AOU to NAOU ; 18 July 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- +2 IF '$DATA(PSDSITE)
- DO ^PSDSET
- if '$DATA(PSDSITE)
- QUIT
- +3 KILL LOC("TR")
- SET CNT=0
- SET PSDUZ=DUZ
- +4 WRITE !!,"This option will copy the stock entries from one AR/WS AOU into NAOUs you ",!,"select. No more than 10 transfers are allowed at a time.",!,"Inactive drugs will not be transferred.",!
- NUM ;ask how many NAOUs
- +1 WRITE !
- KILL DA,DIR,DIRUT
- SET DIR(0)="SO^1:Transfer to one NAOU;2:Transfer to multiple NAOUs"
- SET DIR("A")="Select Transfer Type"
- +2 SET DIR("?",1)="Answer '1' if transfer to only ONE NAOU is desired, '2' if the same"
- SET DIR("?")="stock list is to be copied into more than one NAOU, or '^' to quit."
- +3 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET ANS=+Y
- METHOD ;asks method of stock transfer
- +1 WRITE !!!,"=> Methods of transferring stock drug data."
- +2 WRITE !
- KILL DA,DIR,DIRUT
- SET DIR(0)="SO^1:Drug name only;2:Drug name, stock level, and location code;3:Drug name, stock level, location code, and inv. types"
- SET DIR("A")="Select Transfer Method"
- +3 SET DIR("?",1)="Answer '1' if transfer of ONLY drug name is desired, '2' if you wish to"
- SET DIR("?",2)="copy drug name, stock level, and location code, '3' if you wish to transfer"
- +4 SET DIR("?")="drug name, stock level, location code, and inv. type, or '^' to quit."
- +5 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET MTR=+Y
- FROM ;select AR/WS AOU to transfer stock from
- +1 WRITE !
- KILL DA,DIC
- SET DIC=58.1
- SET DIC(0)="QEA"
- SET DIC("A")="Select AR/WS AOU to transfer drug stock FROM: "
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- SET AOU=+Y
- TO ;select NAOU(s) to transfer stock to
- +1 WRITE !
- KILL DA,DIC
- SET DIC=58.8
- SET DIC(0)="QEA"
- SET DIC("A")="Select NAOU to transfer drug stock INTO: "
- SET DIC("S")="I $P(^(0),""^"",2)'=""P"",$P(^(0),""^"",3)=+PSDSITE"
- +2 DO ^DIC
- KILL DIC
- if (Y<0)&(ANS=1)
- GOTO END
- if (Y<0)&(ANS=2)
- GOTO CHK
- SET LOC("TR",+Y)=""
- SET CNT=CNT+1
- +3 IF CNT>9
- WRITE !!,"You may not transfer TO additional NAOUs at this time.",!,"Enter the option again to transfer to more NAOUs.",!
- +4 IF ANS=2
- IF CNT<10
- GOTO TO
- CHK ;checks for valid NAOUs
- +1 if '$ORDER(LOC("TR",0))
- GOTO END
- +2 WRITE !!,?5,"I will now COPY the ENTIRE drug stock list from ",!,?5,$PIECE(^PSI(58.1,AOU,0),"^")," into"
- FOR TR=0:0
- SET TR=$ORDER(LOC("TR",TR))
- if 'TR
- QUIT
- WRITE !,?5,$PIECE(^PSD(58.8,TR,0),"^")
- +3 WRITE !!,?5,"I will transfer ",$SELECT(MTR=3:"drug name, stock level, location code and types.",MTR=2:"drug name, stock level and location code.",1:"drug name only.")
- +4 WRITE !!
- KILL DA,DIR,DIRUT
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Are you sure that is what you want to do"
- +5 SET DIR("?",1)="Answer 'YES' if you wish to transfer stock entries,"
- SET DIR("?")="answer 'NO' or <RET> if you do not."
- +6 DO ^DIR
- KILL DIR
- IF 'Y!$DATA(DIRUT)
- GOTO END
- QUE WRITE !!,"This job will automatically be queued to run in the background.",!,"You'll be notified by a MailMan message when the transfer is completed.",!
- +1 SET NAOUT=""
- FOR TR=0:0
- SET TR=$ORDER(LOC("TR",TR))
- if 'TR
- QUIT
- SET NAOUT=NAOUT_TR_","
- +2 SET ZTIO=""
- SET ZTDTH=$HOROLOG
- SET ZTRTN="^PSDTRA1"
- SET ZTDESC="Transfer AR/WS Stock to NAOU"
- SET (ZTSAVE("MTR"),ZTSAVE("NAOUT"),ZTSAVE("AOU"),ZTSAVE("PSDUZ"))=""
- +3 DO ^%ZTLOAD
- WRITE !!,"Transfer AR/WS Stock Drugs to NAOU has been queued.",!
- END KILL ANS,AOU,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LOC,MTR,NAOUT,PSDUZ,TR,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"