source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJ200A.m@ 1261

Last change on this file since 1261 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1PSJ200A ;BIR/MV-UTILITY TO CORRECT CHANGED USER NAMES IN IV'S ;30 APR 97 / 8:39 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**58**;16 DEC 97
3 ;
4 I '$L($O(^XTMP("PSJ NEW PERSON",0))) D Q
5 .W !!," This option doesn't need to be run. All changed names in IVs have "
6 .W !," been corrected. Please have IRM remove this option from your menu."
7 I '$$PRIV Q
8 K PSJL,PSJPT,DUOUT,DTOUT
9 W @IOF,!," The following user names were found in IV orders. These names have either",!," been deleted, changed, or are duplicates in the NEW PERSON file.",!
10 S PSJL=0 F S PSJL=$O(^XTMP("PSJ NEW PERSON",1,PSJL)) Q:PSJL="" D
11 .W !?2,PSJL
12 W !!," Please do one of the following:"
13 W !," a. If the name has changed, pick the correct name from the NEW PERSON file."
14 W !," b. If the person has been deleted from the file, please see the appropriate",!?3," person to get this named added back into the NEW PERSON file and rerun this",!?3," option."
15 W !! S PSJL=0 F S PSJL=$O(^XTMP("PSJ NEW PERSON",1,PSJL)) Q:PSJL=""!($G(DUOUT)) D
16 .K PSJPT S PSJPT=$$200
17 .S:PSJPT=-1 PSJB=1 I PSJPT'=-1 S ^XTMP("PSJ NEW1",PSJL)=PSJPT
18 I '$D(PSJB) W !!," Finished. Please have IRM remove this option"
19 I W " (PSJI 200) from",!," your menu, as it is no longer needed."
20 E W !!,"Not all names have been corrected, PLEASE RERUN THIS OPTION!"
21 K PSJB,PSJC,PSJL,PSJPT,PSJDFN,PSJORD,PSJNUM
22 S ZTIO="",ZTRTN="SEARCH^PSJ200A",ZTDESC="Correct names in IV orders"
23 S ZTDTH=$H D ^%ZTLOAD
24 Q
25200() ;
26201 K DUOUT,DTOUT W ! K DIC S DIC="^VA(200,",DIC(0)="AEMQ"
27 S DIC("A")=" Please select the correct name to replace "_PSJL_" : "
28 D ^DIC K DIC S PSJPT=Y
29 I +PSJPT'=-1 S DIR(0)="Y",DIR("A")="Are you sure "_$P(^VA(200,+Y,0),"^")_" is the correct choice" D ^DIR I Y=0 G 201
30 Q +PSJPT
31 ;
32PRIV() ;
33 I $D(^XUSEC("PSJI MGR",DUZ))
34 E W !," You must hold the PSJI MGR security to run this routine"
35 Q $T
36 ;
37SEARCH ;
38 F PSJ1=0 F S PSJ1=$O(^XTMP("PSJ NEW1",PSJ1)) Q:PSJ1="" D
39 .F PSJ2=0:0 S PSJ2=$O(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2)) Q:'PSJ2 D
40 ..F PSJ3=0:0 S PSJ3=$O(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3)) Q:'PSJ3 F PSJ4=0:0 S PSJ4=$O(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3,PSJ4)) Q:'PSJ4 D
41 ...K DA,DIE S DIE="^PS(55,"_PSJ2_",""IV"","_PSJ3_",""A"",",DA(2)=PSJ2,DA(1)=PSJ3,DA=PSJ4
42 ...S PSJDUZ=^XTMP("PSJ NEW1",PSJ1)
43 ...S DR=".06////"_PSJDUZ D ^DIE K DIE,DA
44 ...I +^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3,PSJ4) D NOW^%DTC D VF^PSJUTL3(PSJ3,PSJ2,+PSJDUZ,%)
45 ...K PSJDUZ,^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3)
46 ...S PSJC=$S('$D(PSJC):1,1:PSJC+1) ;W:((PSJC#25)=0) "."
47 .K ^XTMP("PSJ NEW1",PSJ1)
48 K PSJ1,PSJ2,PSJ3,PSJ4
49 D M S ZTIO="@" Q
50M ; sends mail message when complete
51 I $L($O(^XTMP("PSJ NEW PERSON",0))) Q
52 K XMY S XMSUB="Changed names in IV orders",XMTEXT="PSJ1(",XMY(DUZ)=""
53 S XMDUZ="PSJ*5*58 install",PSJ1(1)=""
54 S PSJ1(2)="The process that has replaced the changed names in the IV orders has finished.",PSJ1(3)=""
55 S PSJ1(4)="Please have IRM remove the PSJI ACTIVITY LOG VA200 option, as it is no"
56 S PSJ1(5)="longer needed." D ^XMD K XMSUB,XMDUZ,XMTEXT,PSJ1
57 Q
Note: See TracBrowser for help on using the repository browser.