- 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 ;
