Routine: PSJ200A

PSJ200A  ;BIR/MV-UTILITY TO CORRECT CHANGED USER NAMES IN IV'S ;30 APR 97 / 8:39 AM

 ;;5.0; INPATIENT MEDICATIONS ;**58**;16 DEC 97

 I '$L($O(^XTMP("PSJ NEW PERSON",0))) D  Q

 .W !!," This option doesn't need to be run.  All changed names in IVs have "

 .W !," been corrected.  Please have IRM remove this option from your menu."

 I '$$PRIV Q

 K PSJL,PSJPT,DUOUT,DTOUT

 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.",!

 S PSJL=0 F  S PSJL=$O(^XTMP("PSJ NEW PERSON",1,PSJL)) Q:PSJL=""  D

 .W !?2,PSJL

 W !!," Please do one of the following:"

 W !," a. If the name has changed, pick the correct name from the NEW PERSON file."

 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."

 W !! S PSJL=0 F  S PSJL=$O(^XTMP("PSJ NEW PERSON",1,PSJL)) Q:PSJL=""!($G(DUOUT))  D

 .K PSJPT S PSJPT=$$200

 .S:PSJPT=-1 PSJB=1 I PSJPT'=-1 S ^XTMP("PSJ NEW1",PSJL)=PSJPT

 I '$D(PSJB) W !!," Finished. Please have IRM remove this option"

 I  W " (PSJI 200) from",!," your menu, as it is no longer needed."

 E  W !!,"Not all names have been corrected, PLEASE RERUN THIS OPTION!"

 K PSJB,PSJC,PSJL,PSJPT,PSJDFN,PSJORD,PSJNUM

 S ZTIO="",ZTRTN="SEARCH^PSJ200A",ZTDESC="Correct names in IV orders"

 S ZTDTH=$H D ^%ZTLOAD

200()          ;

201 K DUOUT,DTOUT W ! K DIC S DIC="^VA(200,",DIC(0)="AEMQ"

 S DIC("A")=" Please select the correct name to replace "_PSJL_" : "

 D ^DIC K DIC S PSJPT=Y

 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

 Q +PSJPT

PRIV() ;

 I $D(^XUSEC("PSJI MGR",DUZ))

 E  W !," You must hold the PSJI MGR security to run this routine"

 Q $T

SEARCH ;

 F PSJ1=0 F  S PSJ1=$O(^XTMP("PSJ NEW1",PSJ1)) Q:PSJ1=""  D

 .F PSJ2=0:0 S PSJ2=$O(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2)) Q:'PSJ2  D

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

 ...K DA,DIE S DIE="^PS(55,"_PSJ2_",""IV"","_PSJ3_",""A"",",DA(2)=PSJ2,DA(1)=PSJ3,DA=PSJ4

 ...S PSJDUZ=^XTMP("PSJ NEW1",PSJ1)

 ...S DR=".06////"_PSJDUZ D ^DIE K DIE,DA

 ...I +^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3,PSJ4) D NOW^%DTC D VF^PSJUTL3(PSJ3,PSJ2,+PSJDUZ,%)

 ...K PSJDUZ,^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3)

 ...S PSJC=$S('$D(PSJC):1,1:PSJC+1) ;W:((PSJC#25)=0) "."

 .K ^XTMP("PSJ NEW1",PSJ1)

 K PSJ1,PSJ2,PSJ3,PSJ4

 D M S ZTIO="@" Q

M ; sends mail message when complete

 I $L($O(^XTMP("PSJ NEW PERSON",0))) Q

 K XMY S XMSUB="Changed names in IV orders",XMTEXT="PSJ1(",XMY(DUZ)=""

 S XMDUZ="PSJ*5*58 install",PSJ1(1)=""

 S PSJ1(2)="The process that has replaced the changed names in the IV orders has finished.",PSJ1(3)=""

 S PSJ1(4)="Please have IRM remove the PSJI ACTIVITY LOG VA200 option, as it is no"

 S PSJ1(5)="longer needed." D ^XMD K XMSUB,XMDUZ,XMTEXT,PSJ1

PSJ200A   ;BIR/MV-UTILITY TO CORRECT CHANGED USER NAMES IN IV'S ;30 APR 97 / 8:39 AM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**58**;16 DEC 97

 +2       ;

 +3        IF '$LENGTH($ORDER(^XTMP("PSJ NEW PERSON",0)))

               Begin DoDot:1

 +4                WRITE !!," This option doesn't need to be run.  All changed names in IVs have "

 +5                WRITE !," been corrected.  Please have IRM remove this option from your menu."

               End DoDot:1

               QUIT

 +6        IF '$$PRIV

               QUIT

 +7        KILL PSJL,PSJPT,DUOUT,DTOUT

 +8        WRITE @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.",!

 +9        SET PSJL=0

FOR

               SET PSJL=$ORDER(^XTMP("PSJ NEW PERSON",1,PSJL))

               IF PSJL=""

                   QUIT

               Begin DoDot:1

 +10               WRITE !?2,PSJL

               End DoDot:1

 +11       WRITE !!," Please do one of the following:"

 +12       WRITE !," a. If the name has changed, pick the correct name from the NEW PERSON file."

 +13       WRITE !," 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."

 +14       WRITE !!

           SET PSJL=0

FOR

               SET PSJL=$ORDER(^XTMP("PSJ NEW PERSON",1,PSJL))

               IF PSJL=""!($GET(DUOUT))

                   QUIT

               Begin DoDot:1

 +15               KILL PSJPT

                   SET PSJPT=$$200

 +16               IF PSJPT=-1

                       SET PSJB=1

                   IF PSJPT'=-1

                       SET ^XTMP("PSJ NEW1",PSJL)=PSJPT

               End DoDot:1

 +17       IF '$DATA(PSJB)

               WRITE !!," Finished. Please have IRM remove this option"

 +18      IF $TEST

               WRITE " (PSJI 200) from",!," your menu, as it is no longer needed."

 +19      IF '$TEST

               WRITE !!,"Not all names have been corrected, PLEASE RERUN THIS OPTION!"

 +20       KILL PSJB,PSJC,PSJL,PSJPT,PSJDFN,PSJORD,PSJNUM

 +21       SET ZTIO=""

           SET ZTRTN="SEARCH^PSJ200A"

           SET ZTDESC="Correct names in IV orders"

 +22       SET ZTDTH=$HOROLOG

           DO ^%ZTLOAD

 +23       QUIT

200()     ;

201        KILL DUOUT,DTOUT

           WRITE !

           KILL DIC

           SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

 +1        SET DIC("A")=" Please select the correct name to replace "_PSJL_" : "

 +2        DO ^DIC

           KILL DIC

           SET PSJPT=Y

 +3        IF +PSJPT'=-1

               SET DIR(0)="Y"

               SET DIR("A")="Are you sure "_$PIECE(^VA(200,+Y,0),"^")_" is the correct choice"

               DO ^DIR

               IF Y=0

                   GOTO 201

 +4        QUIT +PSJPT

 +5       ;

PRIV()    ;

 +1        IF $DATA(^XUSEC("PSJI MGR",DUZ))

 +2       IF '$TEST

               WRITE !," You must hold the PSJI MGR security to run this routine"

 +3        QUIT $TEST

 +4       ;

SEARCH    ;

 +1        FOR PSJ1=0

FOR

                   SET PSJ1=$ORDER(^XTMP("PSJ NEW1",PSJ1))

                   IF PSJ1=""

                       QUIT

                   Begin DoDot:1

 +2                    FOR PSJ2=0:0

                           SET PSJ2=$ORDER(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2))

                           IF 'PSJ2

                               QUIT

                           Begin DoDot:2

 +3                            FOR PSJ3=0:0

                                   SET PSJ3=$ORDER(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3))

                                   IF 'PSJ3

                                       QUIT

                                   FOR PSJ4=0:0

                                       SET PSJ4=$ORDER(^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3,PSJ4))

                                       IF 'PSJ4

                                           QUIT

                                       Begin DoDot:3

 +4                                        KILL DA,DIE

                                           SET DIE="^PS(55,"_PSJ2_",""IV"","_PSJ3_",""A"","

                                           SET DA(2)=PSJ2

                                           SET DA(1)=PSJ3

                                           SET DA=PSJ4

 +5                                        SET PSJDUZ=^XTMP("PSJ NEW1",PSJ1)

 +6                                        SET DR=".06////"_PSJDUZ

                                           DO ^DIE

                                           KILL DIE,DA

 +7                                        IF +^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3,PSJ4)

                                               DO NOW^%DTC

                                               DO VF^PSJUTL3(PSJ3,PSJ2,+PSJDUZ,%)

 +8                                        KILL PSJDUZ,^XTMP("PSJ NEW PERSON",1,PSJ1,PSJ2,PSJ3)

 +9       ;W:((PSJC#25)=0) "."

                                           SET PSJC=$SELECT('$DATA(PSJC):1,1:PSJC+1)

                                       End DoDot:3

                           End DoDot:2

 +10                   KILL ^XTMP("PSJ NEW1",PSJ1)

                   End DoDot:1

 +11       KILL PSJ1,PSJ2,PSJ3,PSJ4

 +12       DO M

           SET ZTIO="@"

           QUIT

M         ; sends mail message when complete

 +1        IF $LENGTH($ORDER(^XTMP("PSJ NEW PERSON",0)))

               QUIT

 +2        KILL XMY

           SET XMSUB="Changed names in IV orders"

           SET XMTEXT="PSJ1("

           SET XMY(DUZ)=""

 +3        SET XMDUZ="PSJ*5*58 install"

           SET PSJ1(1)=""

 +4        SET PSJ1(2)="The process that has replaced the changed names in the IV orders has finished."

           SET PSJ1(3)=""

 +5        SET PSJ1(4)="Please have IRM remove the PSJI ACTIVITY LOG VA200 option, as it is no"

 +6        SET PSJ1(5)="longer needed."

           DO ^XMD

           KILL XMSUB,XMDUZ,XMTEXT,PSJ1

 +7        QUIT

PSJ200A.m