- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJ200 4389 printed Jan 18, 2025@03:06:59 Page 2
- 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