PSJ200 ;BIR/RSB-UTILITY TO CORRECT CHANGED USER NAMES IN IV'S ;30 APR 97 / 8:39 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
; DO NOT DELETE THIS ROUTINE, IT IS CALLED BY MANY PROTOCOL
; ENTRY ACTIONS TO CHANGE THE SCREEN LENGTH IN LISTMAN!
;
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",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",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,PSJ1,PSJ2,PSJ3,PSJ4,PSJNUM
S ZTIO="",ZTRTN="SEARCH^PSJ200",ZTDESC="Correct names in IV orders"
S ZTDTH=$H D ^%ZTLOAD
Q
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",PSJ1,PSJ2)) Q:'PSJ2 D
..D CONVERT(PSJ2,0)
..F PSJ3=0:0 S PSJ3=$O(^XTMP("PSJ NEW PERSON",PSJ1,PSJ2,PSJ3)) Q:'PSJ3 D
...K DA,DIE S DIE="^PS(55,"_PSJ2_",""IV"",",DA(1)=PSJ2,DA=PSJ3
...S DR="135////"_^XTMP("PSJ NEW1",PSJ1) D ^DIE K DIE,DA
...S X=$P($G(^PS(55,PSJ2,"IV",PSJ3,0)),"^",21),PSOC=$S(X=0:"SN",X]"":"ZC",1:"SN") D EN1^PSJHL2(PSJ2,PSOC,PSJ3_"V")
...K ^XTMP("PSJ NEW PERSON",PSJ1,PSJ2,PSJ3)
...S PSJC=$S('$D(PSJC):1,1:PSJC+1) ;W:((PSJC#25)=0) "."
.K ^XTMP("PSJ NEW1",PSJ1)
D M S ZTIO="@" Q
CONVERT(DFN,TYPE) ;
; Convert existing UD orders to new format. Only run once/patient, and
; only converts orders with a stop date<(5.0 Install date-365)
; DFN = Patient IEN
; TYPE = Background or Interactive mode
;
I '$D(^PS(55,DFN,0)) Q
N ADS,ADS1,DDRG,ND,ON,ON1,PSOC,PSGDT,STAT,STPDT,STS,X,XX,X1,X2
D NOW^%DTC S X1=$P(%,"."),X2=-365 D C^%DTC S PSGDT=X
;Convert and Backfill IV orders.
F STPDT=PSGDT:0 S STPDT=$O(^PS(55,DFN,"IV","AIS",STPDT)) Q:'STPDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",STPDT,ON)) Q:'ON I '$G(^PS(55,DFN,"IV",ON,.2)) D
.S ND=$G(^PS(55,DFN,"IV",ON,6)) F ADS="AD","SOL" S ADS1=$O(^PS(55,DFN,"IV",ON,ADS)) F ON1=0:0 S ON1=$O(^PS(55,DFN,"IV",ON,ADS,ON1)) Q:'ON1 Q:$G(^PS(55,DFN,"IV",ON,.2)) S XX=+$G(^PS(55,DFN,"IV",ON,ADS,ON1,0)) D
..S:XX XX=$S(ADS="AD":$P($G(^PS(52.6,XX,0)),U,11),1:$P($G(^PS(52.7,XX,0)),U,11)) I XX I $P(^PS(50.7,XX,0),U,3)=1 S ^PS(55,DFN,"IV",ON,.2)=XX_U_$P(ND,U,2,3) W:TYPE "."
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="Inpatient Medications Version 5.0 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 this option (PSJI 200) from your menu, as it is no"
S PSJ1(5)="longer needed." D ^XMD K XMSUB,XMDUZ,XMTEXT,PSJ1 Q
;
A(LONG,SHORT,SHRINK) ; Resizes list area
; copied this from TIU RESIZE^TIULM
N PSJBM S PSJBM=$S(VALMMENU:SHORT,+$G(SHRINK):SHORT,1:LONG)
I VALM("BM")'=PSJBM S VALMBCK="R" D
.S VALM("BM")=PSJBM,VALM("LINES")=(PSJBM-VALM("TM"))+1
.I +$G(VALMCC) D RESET^VALM4
Q
PSJ200 ;BIR/RSB-UTILITY TO CORRECT CHANGED USER NAMES IN IV'S ;30 APR 97 / 8:39 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ; DO NOT DELETE THIS ROUTINE, IT IS CALLED BY MANY PROTOCOL
+3 ; ENTRY ACTIONS TO CHANGE THE SCREEN LENGTH IN LISTMAN!
+4 ;
+5 IF '$LENGTH($ORDER(^XTMP("PSJ NEW PERSON",0)))
Begin DoDot:1
+6 WRITE !!," This option doesn't need to be run. All changed names in IVs have "
+7 WRITE !," been corrected. Please have IRM remove this option from your menu."
End DoDot:1
QUIT
+8 IF '$$PRIV
QUIT
+9 KILL PSJL,PSJPT,DUOUT,DTOUT
+10 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.",!
+11 SET PSJL=0
FOR
SET PSJL=$ORDER(^XTMP("PSJ NEW PERSON",PSJL))
IF PSJL=""
QUIT
Begin DoDot:1
+12 WRITE !?2,PSJL
End DoDot:1
+13 WRITE !!," Please do one of the following:"
+14 WRITE !," a. If the name has changed, pick the correct name from the NEW PERSON file."
+15 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."
+16 WRITE !!
SET PSJL=0
FOR
SET PSJL=$ORDER(^XTMP("PSJ NEW PERSON",PSJL))
IF PSJL=""!($GET(DUOUT))
QUIT
Begin DoDot:1
+17 KILL PSJPT
SET PSJPT=$$200
+18 IF PSJPT=-1
SET PSJB=1
IF PSJPT'=-1
SET ^XTMP("PSJ NEW1",PSJL)=PSJPT
End DoDot:1
+19 IF '$DATA(PSJB)
WRITE !!," Finished. Please have IRM remove this option"
+20 IF $TEST
WRITE " (PSJI 200) from",!," your menu, as it is no longer needed."
+21 IF '$TEST
WRITE !!,"Not all names have been corrected, PLEASE RERUN THIS OPTION!"
+22 KILL PSJB,PSJC,PSJL,PSJPT,PSJDFN,PSJORD,PSJ1,PSJ2,PSJ3,PSJ4,PSJNUM
+23 SET ZTIO=""
SET ZTRTN="SEARCH^PSJ200"
SET ZTDESC="Correct names in IV orders"
+24 SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+25 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",PSJ1,PSJ2))
IF 'PSJ2
QUIT
Begin DoDot:2
+3 DO CONVERT(PSJ2,0)
+4 FOR PSJ3=0:0
SET PSJ3=$ORDER(^XTMP("PSJ NEW PERSON",PSJ1,PSJ2,PSJ3))
IF 'PSJ3
QUIT
Begin DoDot:3
+5 KILL DA,DIE
SET DIE="^PS(55,"_PSJ2_",""IV"","
SET DA(1)=PSJ2
SET DA=PSJ3
+6 SET DR="135////"_^XTMP("PSJ NEW1",PSJ1)
DO ^DIE
KILL DIE,DA
+7 SET X=$PIECE($GET(^PS(55,PSJ2,"IV",PSJ3,0)),"^",21)
SET PSOC=$SELECT(X=0:"SN",X]"":"ZC",1:"SN")
DO EN1^PSJHL2(PSJ2,PSOC,PSJ3_"V")
+8 KILL ^XTMP("PSJ NEW PERSON",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 DO M
SET ZTIO="@"
QUIT
CONVERT(DFN,TYPE) ;
+1 ; Convert existing UD orders to new format. Only run once/patient, and
+2 ; only converts orders with a stop date<(5.0 Install date-365)
+3 ; DFN = Patient IEN
+4 ; TYPE = Background or Interactive mode
+5 ;
+6 IF '$DATA(^PS(55,DFN,0))
QUIT
+7 NEW ADS,ADS1,DDRG,ND,ON,ON1,PSOC,PSGDT,STAT,STPDT,STS,X,XX,X1,X2
+8 DO NOW^%DTC
SET X1=$PIECE(%,".")
SET X2=-365
DO C^%DTC
SET PSGDT=X
+9 ;Convert and Backfill IV orders.
+10 FOR STPDT=PSGDT:0
SET STPDT=$ORDER(^PS(55,DFN,"IV","AIS",STPDT))
IF 'STPDT
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",STPDT,ON))
IF 'ON
QUIT
IF '$GET(^PS(55,DFN,"IV",ON,.2))
Begin DoDot:1
+11 SET ND=$GET(^PS(55,DFN,"IV",ON,6))
FOR ADS="AD","SOL"
SET ADS1=$ORDER(^PS(55,DFN,"IV",ON,ADS))
FOR ON1=0:0
SET ON1=$ORDER(^PS(55,DFN,"IV",ON,ADS,ON1))
IF 'ON1
QUIT
IF $GET(^PS(55,DFN,"IV",ON,.2))
QUIT
SET XX=+$GET(^PS(55,DFN,"IV",ON,ADS,ON1,0))
Begin DoDot:2
+12 IF XX
SET XX=$SELECT(ADS="AD":$PIECE($GET(^PS(52.6,XX,0)),U,11),1:$PIECE($GET(^PS(52.7,XX,0)),U,11))
IF XX
IF $PIECE(^PS(50.7,XX,0),U,3)=1
SET ^PS(55,DFN,"IV",ON,.2)=XX_U_$PIECE(ND,U,2,3)
IF TYPE
WRITE "."
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
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="Inpatient Medications Version 5.0 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 this option (PSJI 200) from your menu, as it is no"
+6 SET PSJ1(5)="longer needed."
DO ^XMD
KILL XMSUB,XMDUZ,XMTEXT,PSJ1
QUIT
+7 ;
A(LONG,SHORT,SHRINK) ; Resizes list area
+1 ; copied this from TIU RESIZE^TIULM
+2 NEW PSJBM
SET PSJBM=$SELECT(VALMMENU:SHORT,+$GET(SHRINK):SHORT,1:LONG)
+3 IF VALM("BM")'=PSJBM
SET VALMBCK="R"
Begin DoDot:1
+4 SET VALM("BM")=PSJBM
SET VALM("LINES")=(PSJBM-VALM("TM"))+1
+5 IF +$GET(VALMCC)
DO RESET^VALM4
End DoDot:1
+6 QUIT
