APSPERRY ;IHS/DSD/PR - Copy drug file for each selected division; [ 09/09/97 8:45 AM ]
;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
;
EN(PSOMAKE) ;EP
;D EN^PSOPERRY(SITE) ;user will NOT be asked site.
; (.SITE) ;User will NOT be asked site.
; () ;user will be asked site.
;
I $D(PSOMAKE) D Q
.I '$O(PSOMAKE(0)) S PSOMAKE(PSOMAKE)=""
.D Q
;
;
K PSOMAKE,PSOQUIT
F S DIC=59,DIC(0)="AEQM",DIC("A")="Select Division(s): " D ^DIC S:Y>0 PSOMAKE(+Y)="" I Y'>0 Q
I '$O(PSOMAKE(0)) S PSOQUIT=1
I $D(PSOQUIT) D K Q
;
W !!!,"OK, I will Copy the existing drug file for divisions: " F PSODA=0:0 S PSODA=$O(PSOMAKE(PSODA)) Q:'PSODA W !,$P(^PS(59,PSODA,0),U)
;
;Verify user wants to continue
F W !!,"OK to continue" S %=2 D YN^DICN W:%=0 " Answer Yes or No" G:%'=1&(%'=0) K Q:%=1
;
;
Q ;EP
K IO("Q"),%ZIS,IOP,ZTDTH,ZTSAVE,ZTSK,ZTQUEUED
S %ZIS="QM" D ^%ZIS I POP D K Q
I $D(IO("Q")) S ZTIO=ION,ZTSAVE("PSO*")="",ZTSAVE("DUZ(")="",ZTRTN="EN2^PSOPERRY",ZTDTH=$H D ^%ZTLOAD W !,"JOB QUEUED." D ^%ZISC D K Q
;
EN2 ;EP Tman entry
;Create new duplicate drug entry here.
;Stuff 'PSOSITE' (internal DA to 59) into the new division field.
;
U IO W @IOF,"Drug file copy in progress."
F PSOSITE=0:0 S PSOSITE=$O(PSOMAKE(PSOSITE)) Q:'PSOSITE I $D(^PS(59,PSOSITE,0)) W !!!!,"Copying new drug file for site: ",$P(^(0),U) D AUTO
I IO'=IO(0) W !!,"FINISHED." W @IOF D ^%ZISC
D K Q
;
;
AUTO ;Auto duplicate drug data with new division.
;
;Check that first site in site file has been established
S PSOBASE=$O(^PS(59,0)) I '$D(^PSDRUG("ZDIV",PSOBASE)) W !,"Unable to continue, no base to operate from." Q
;
;Check division and be sure it has not already been set up with
;the drug file.
I $D(^PSDRUG("ZDIV",PSOSITE)) W !,"Site ",$P(^PS(59,PSOSITE,0),U)," has already been assigned the drug file. " Q
;
;Get the entry from the drug file to duplicate
F PSODA=0:0 S PSODA=$O(^PSDRUG("ZDIV",PSOBASE,PSODA)) Q:'PSODA I $D(^PSDRUG(PSODA,0)) D
.S X=$P(^PSDRUG(PSODA,0),U)
.S DIC="^PSDRUG("
.S DIC(0)="L"
.D FILE^DICN S PSONEW=+Y
.S %X="^PSDRUG("_PSODA_","
.S %Y="^PSDRUG("_PSONEW_","
.D %XY^%RCR
.S DIE="^PSDRUG(",DA=PSONEW,DR="9999999.03////^S X=PSOSITE" D ^DIE
.S DIK="^PSDRUG(",DA=PSONEW D IX1^DIK
.W "."
K ;
APSPERRY ;IHS/DSD/PR - Copy drug file for each selected division; [ 09/09/97 8:45 AM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ;
EN(PSOMAKE) ;EP
+1 ;D EN^PSOPERRY(SITE) ;user will NOT be asked site.
+2 ; (.SITE) ;User will NOT be asked site.
+3 ; () ;user will be asked site.
+4 ;
+5 IF $DATA(PSOMAKE)
Begin DoDot:1
+6 IF '$ORDER(PSOMAKE(0))
SET PSOMAKE(PSOMAKE)=""
+7 DO Q
End DoDot:1
QUIT
+8 ;
+9 ;
+10 KILL PSOMAKE,PSOQUIT
+11 FOR
SET DIC=59
SET DIC(0)="AEQM"
SET DIC("A")="Select Division(s): "
DO ^DIC
IF Y>0
SET PSOMAKE(+Y)=""
IF Y'>0
QUIT
+12 IF '$ORDER(PSOMAKE(0))
SET PSOQUIT=1
+13 IF $DATA(PSOQUIT)
DO K
QUIT
+14 ;
+15 WRITE !!!,"OK, I will Copy the existing drug file for divisions: "
FOR PSODA=0:0
SET PSODA=$ORDER(PSOMAKE(PSODA))
IF 'PSODA
QUIT
WRITE !,$PIECE(^PS(59,PSODA,0),U)
+16 ;
+17 ;Verify user wants to continue
+18 FOR
WRITE !!,"OK to continue"
SET %=2
DO YN^DICN
IF %=0
WRITE " Answer Yes or No"
IF %'=1&(%'=0)
GOTO K
IF %=1
QUIT
+19 ;
+20 ;
Q ;EP
+1 KILL IO("Q"),%ZIS,IOP,ZTDTH,ZTSAVE,ZTSK,ZTQUEUED
+2 SET %ZIS="QM"
DO ^%ZIS
IF POP
DO K
QUIT
+3 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTSAVE("PSO*")=""
SET ZTSAVE("DUZ(")=""
SET ZTRTN="EN2^PSOPERRY"
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
WRITE !,"JOB QUEUED."
DO ^%ZISC
DO K
QUIT
+4 ;
EN2 ;EP Tman entry
+1 ;Create new duplicate drug entry here.
+2 ;Stuff 'PSOSITE' (internal DA to 59) into the new division field.
+3 ;
+4 USE IO
WRITE @IOF,"Drug file copy in progress."
+5 FOR PSOSITE=0:0
SET PSOSITE=$ORDER(PSOMAKE(PSOSITE))
IF 'PSOSITE
QUIT
IF $DATA(^PS(59,PSOSITE,0))
WRITE !!!!,"Copying new drug file for site: ",$PIECE(^(0),U)
DO AUTO
+6 IF IO'=IO(0)
WRITE !!,"FINISHED."
WRITE @IOF
DO ^%ZISC
+7 DO K
QUIT
+8 ;
+9 ;
AUTO ;Auto duplicate drug data with new division.
+1 ;
+2 ;Check that first site in site file has been established
+3 SET PSOBASE=$ORDER(^PS(59,0))
IF '$DATA(^PSDRUG("ZDIV",PSOBASE))
WRITE !,"Unable to continue, no base to operate from."
QUIT
+4 ;
+5 ;Check division and be sure it has not already been set up with
+6 ;the drug file.
+7 IF $DATA(^PSDRUG("ZDIV",PSOSITE))
WRITE !,"Site ",$PIECE(^PS(59,PSOSITE,0),U)," has already been assigned the drug file. "
QUIT
+8 ;
+9 ;Get the entry from the drug file to duplicate
+10 FOR PSODA=0:0
SET PSODA=$ORDER(^PSDRUG("ZDIV",PSOBASE,PSODA))
IF 'PSODA
QUIT
IF $DATA(^PSDRUG(PSODA,0))
Begin DoDot:1
+11 SET X=$PIECE(^PSDRUG(PSODA,0),U)
+12 SET DIC="^PSDRUG("
+13 SET DIC(0)="L"
+14 DO FILE^DICN
SET PSONEW=+Y
+15 SET %X="^PSDRUG("_PSODA_","
+16 SET %Y="^PSDRUG("_PSONEW_","
+17 DO %XY^%RCR
+18 SET DIE="^PSDRUG("
SET DA=PSONEW
SET DR="9999999.03////^S X=PSOSITE"
DO ^DIE
+19 SET DIK="^PSDRUG("
SET DA=PSONEW
DO IX1^DIK
+20 WRITE "."
End DoDot:1
K ;
