ORY535R ;ISL/TDP - Restore-install for patch OR*3*535 ;Sep 12, 2024@13:35:57
;;3.0;ORDER ENTRY/RESULTS REPORTING;**535**;Dec 17, 1997;Build 20
;
CLRINDX ;Delete the "B" index of file 100.04
N DIK
D BMES^XPDUTL("Clearing 'B' indexes for file 100.04")
S DIK="^ORD(100.04,",DIK(1)=".01"
D ENALL2^DIK
D MES^XPDUTL(" Completed!")
Q
;
RSTR ; Initiate restore processes
D ACTIV("METFORMIN EGFR - LAB RESULTS",1,0)
D ACTIV("GLUCOPHAGE - LAB RESULTS",0,0)
D RENAME("^OCXS(860.3,","METFORMIN ORDER","GLUCOPHAGE ORDER")
D RECOMPILE
D RMVLCL
D RMVB
D CLRINDX
D REINDEX
;D RMVPARAM ;Unable to remove entries as the parameter is removed before this routine is run.
Q
;
ACTIV(ORCHKRL,ORACTIV,PST) ; Inactivate Order Check Rule
; ORCHKRL = Name of Order Check Rule in file 860.2
; ORACTIV = Status of Order Check Rule. 0 = Active, 1 = Inactive, No value defaults to Active
; PST = Indicates METFORMIN EGFR - LAB RESULTS from Post-init code (1 = yes, 0 = no)
N ORACT,ORACT1,ORCHKRLIEN
Q:$G(ORCHKRL)=""
S ORACTIV=+$G(ORACTIV) D
. I ORACTIV=1 S ORACT="Inactivating ",ORACT1="inactivated."
. E S ORACT="Activating ",ORACT1="activated."
S ORCHKRLIEN=$O(^OCXS(860.2,"B",ORCHKRL,0))
I 'ORCHKRLIEN D Q
. I PST Q ;METFORMIN EGFR - LAB RESULTS won't exist yet on initial install
. D BMES^XPDUTL(" "_ORCHKRL_" does not exist in the ORDER CHECK")
. D MES^XPDUTL(" RULE (#860.2) file.")
. Q
I +$G(^OCXS(860.2,ORCHKRLIEN,"INACT"))=ORACTIV D Q
. D BMES^XPDUTL(" "_ORCHKRL_" is already "_ORACT1_" ABORTING action!")
. Q
D BMES^XPDUTL(ORACT_ORCHKRL_" in the ORDER CHECK")
D MES^XPDUTL(" RULE (#860.2) file.")
S ^OCXS(860.2,ORCHKRLIEN,"INACT")=ORACTIV
D BMES^XPDUTL(" "_ORCHKRL_" has been "_ORACT1)
Q
;
RENAME(FILE,OROLD,ORNEW) ; Rename file entry
N CNT,DA,DIC,DIE,DO,DR,FILENM,TEXT,X,Y
Q:$G(FILE)=""
Q:$G(OROLD)=""
Q:$G(ORNEW)=""
S (DIC,DIE)=FILE
S DIC(0)="X"
S X=OROLD
D ^DIC Q:Y<1
S DA=+Y
I 'DA Q
S DIE="^OCXS(860.3,",DR=".01///"_ORNEW
D ^DIE
S FILENM=FILE
S DO=""
D DO^DIC1
I DO(2)'=-1 D
. S FILENM=$P(DO,U,1)_" (#"_$P(DO,U,2)_")"
S CNT=1
S TEXT(CNT)="Renamed "_FILENM_" file entry "_OROLD_" to "_ORNEW_"."
I $L(TEXT(CNT))>66 D
. N DONE
. S DONE=0
. S X=$L(TEXT(CNT))
. F Y=66:-1:1 D Q:DONE
.. I $E(TEXT(CNT),Y)'=" " Q
.. S TEXT(CNT+1)=$E(TEXT(CNT),Y+1,X)
.. S TEXT(CNT)=$E(TEXT(CNT),1,Y)
.. S CNT=CNT+1
.. I $L(TEXT(CNT))<66 S DONE=1
S CNT=1
D BMES^XPDUTL($G(TEXT(CNT)))
F S CNT=$O(TEXT(CNT)) Q:+CNT=0 D MES^XPDUTL(" "_$G(TEXT(CNT)))
Q
RMVB ;Remove the bad "B" new-style field index in the NAME (#.01) field
; of the ORDER CHECK OVERRIDE REASONS (#100.04) file
N MSG,OUTPUT
D BMES^XPDUTL("Deleting New-Style ""B"" index from the Data Dictionary for the")
D MES^XPDUTL("NAME (#.01) field in the ORDER CHECK OVERRIDE REASONS (#100.04) file ...")
D MES^XPDUTL("")
D DELIXN^DDMOD(100.04,"B","KW","OUTPUT","MSG")
I $D(MSG("DIERR")) D Q
. N ERRCODE,ERRTXT,X,Y
. D MES^XPDUTL(" An error occurred while deleting the New-Style ""B"" field index!!!")
. S X=0
. F S X=$O(MSG("DIERR",X)) Q:+X=0 D
.. S ERRCODE=+$G(MSG("DIERR",X))
.. I ERRCODE>0 D MES^XPDUTL(" ERROR CODE: "_ERRCODE)
.. S Y=0
.. F S Y=$O(MSG("DIERR",X,"TEXT",Y)) Q:+Y=0 D
... D MES^XPDUTL(" "_$G(MSG("DIERR",X,"TEXT",1)))
D BMES^XPDUTL(" Completed!")
Q
;
REINDEX ;Reindex "B" cross reference in file 100.04
N DIK
D BMES^XPDUTL("Reindexing the 'B' cross reference for file 100.04")
S DIK="^ORD(100.04,",DIK(1)=".01"
D ENALL^DIK
D MES^XPDUTL(" Completed!")
Q
;
RECOMPILE ;Recompile the Order Check System
N OCXOETIM
D BMES^XPDUTL("---Recompiling Order Check Routines-----------------------------------")
D AUTO^OCXOCMP
D BMES^XPDUTL(" ---Recompiling Complete---")
Q
;
RMVLCL ;Remove Local entries from the ORDER CHECK OVERRIDE REASONS (#100.04) file
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,CNT,DA,DIK
;S MSG(1)=" Patch OR*3*535 created an option to add local Order Check Override"
;S MSG(2)=" Reasons in file 100.04. Now that patch OR*3*535 is being backed out,"
;S MSG(3)=" you have the option to keep the locally created Order Check Override"
;S MSG(4)=" Reasons and by default the new NATIONAL (#.05) field. Answer YES to"
;S MSG(5)=" remove the local entries. Default response is NO."
;RMV1 ;S %=2,%Y=""
;D BMES^XPDUTL("Do you want to delete locally created Order Check Override Reasons in file 100.04")
;D YN^DICN
;D MES^XPDUTL(%Y)
RMV1 K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
D MES^XPDUTL("")
I DTIME>30 S DIR("T")=30
S DIR("?",1)=" Patch OR*3*535 created an option to add local Order Check Override"
S DIR("?",2)=" Reasons in file 100.04. Now that patch OR*3*535 is being backed out,"
S DIR("?",3)=" you have the option to keep the locally created Order Check Override"
S DIR("?",4)=" Reasons and by default the new NATIONAL (#.05) field. Answer YES to"
S DIR("?")=" remove the local entries. Default response is NO."
S DIR(0)="Y"
S MSG(1)="Delete locally created Order Check Override Reasons in file 100.04."
S MSG(2)="Answering YES results in the NATIONAL (#.05) field in the ORDER CHECK"
S MSG(3)="OVERRIDE REASONS (#100.04) file to be removed as well. Proceed?"
S DIR("B")="NO"
D MES^XPDUTL(.MSG)
D ^DIR
D MES^XPDUTL($S(Y=1:"YES",Y=0:"NO",Y="":"NO",1:Y))
I Y["^" D BMES^XPDUTL(" Exiting is not allowed!!"),MES^XPDUTL("") G RMV1
I +Y=0 D Q
. D BMES^XPDUTL(" Skipping deletion of the locally created Order Check Override")
. D MES^XPDUTL(" Reasons and leaving the new NATIONAL (#.05) field installed.")
;I %<1 D
;. I %=0,%Y["?" D MES^XPDUTL(""),MES^XPDUTL(.MSG)
;. I %=-1 D BMES^XPDUTL(" Exiting is not allowed!!!")
;. G RMV1
;I %=2 D BMES^XPDUTL(" Skipping ...") Q
D BMES^XPDUTL("Removing local Order Check Override Reasons...")
S DIK="^ORD(100.04,"
S (CNT,DA)=0
F S DA=$O(^ORD(100.04,DA)) Q:+DA=0 D
. I +$P($G(^ORD(100.04,DA,0)),U,5)=1 Q
. D MES^XPDUTL(" Deleting '"_$P($G(^ORD(100.04,DA,0)),U,1)_"'")
. D ^DIK
. S CNT=CNT+1
D BMES^XPDUTL(" --- "_CNT_" local Order Check Override Reasons removed!")
RMVNTL ;Remove National (#.05) field from the ORDER CHECK OVERRIDE REASONS (#100.04) file and any related data from file entries
N OVRD,VAL4,VAL5
D BMES^XPDUTL("Removing NATIONAL (#.05) field from the ORDER CHECK OVERRIDE")
D MES^XPDUTL("REASONS (#100.04) file ...")
S DIK="^DD(100.04,"
S DA=.05
S DA(1)=100.04
D ^DIK
S OVRD=0
F S OVRD=$O(^ORD(100.04,OVRD)) Q:+OVRD=0 D
. S VAL5=$G(^ORD(100.04,OVRD,0))
. S VAL4=$P(VAL5,U,1,4)
. I VAL4=VAL5 Q
. S ^ORD(100.04,OVRD,0)=VAL4
D BMES^XPDUTL(" ... COMPLETED!")
Q
;
RMVPARAM ;Remove entries made related to the ORK METFORMIN EGFR parameter.
N DA,DIK,ORENTITY,ORINSTANCE,ORPARAM
S ORPARAM=$O(^XTV(8989.51,"B","ORK METFORMIN EGFR",""))
I ORPARAM<1 Q
D BMES^XPDUTL("Removing ORK METFORMIN EGFR parameter entries for all entities...")
S DIK="^XTV(8989.5,"
S ORENTITY=""
F S ORENTITY=$O(^XTV(8989.5,"AC",ORPARAM,ORENTITY)) Q:ORENTITY="" D
. S ORINSTANCE=0
. F S ORINSTANCE=$O(^XTV(8989.5,"AC",ORPARAM,ORENTITY,ORINSTANCE)) Q:+ORINSTANCE=0 D
. . S DA=0
. . F S DA=$O(^XTV(8989.5,"AC",ORPARAM,ORENTITY,ORINSTANCE,DA)) Q:+DA=0 D
. . . D ^DIK
D BMES^XPDUTL(" ... Complete!")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY535R 7399 printed Sep 23, 2025@20:18:49 Page 2
ORY535R ;ISL/TDP - Restore-install for patch OR*3*535 ;Sep 12, 2024@13:35:57
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**535**;Dec 17, 1997;Build 20
+2 ;
CLRINDX ;Delete the "B" index of file 100.04
+1 NEW DIK
+2 DO BMES^XPDUTL("Clearing 'B' indexes for file 100.04")
+3 SET DIK="^ORD(100.04,"
SET DIK(1)=".01"
+4 DO ENALL2^DIK
+5 DO MES^XPDUTL(" Completed!")
+6 QUIT
+7 ;
RSTR ; Initiate restore processes
+1 DO ACTIV("METFORMIN EGFR - LAB RESULTS",1,0)
+2 DO ACTIV("GLUCOPHAGE - LAB RESULTS",0,0)
+3 DO RENAME("^OCXS(860.3,","METFORMIN ORDER","GLUCOPHAGE ORDER")
+4 DO RECOMPILE
+5 DO RMVLCL
+6 DO RMVB
+7 DO CLRINDX
+8 DO REINDEX
+9 ;D RMVPARAM ;Unable to remove entries as the parameter is removed before this routine is run.
+10 QUIT
+11 ;
ACTIV(ORCHKRL,ORACTIV,PST) ; Inactivate Order Check Rule
+1 ; ORCHKRL = Name of Order Check Rule in file 860.2
+2 ; ORACTIV = Status of Order Check Rule. 0 = Active, 1 = Inactive, No value defaults to Active
+3 ; PST = Indicates METFORMIN EGFR - LAB RESULTS from Post-init code (1 = yes, 0 = no)
+4 NEW ORACT,ORACT1,ORCHKRLIEN
+5 if $GET(ORCHKRL)=""
QUIT
+6 SET ORACTIV=+$GET(ORACTIV)
Begin DoDot:1
+7 IF ORACTIV=1
SET ORACT="Inactivating "
SET ORACT1="inactivated."
+8 IF '$TEST
SET ORACT="Activating "
SET ORACT1="activated."
End DoDot:1
+9 SET ORCHKRLIEN=$ORDER(^OCXS(860.2,"B",ORCHKRL,0))
+10 IF 'ORCHKRLIEN
Begin DoDot:1
+11 ;METFORMIN EGFR - LAB RESULTS won't exist yet on initial install
IF PST
QUIT
+12 DO BMES^XPDUTL(" "_ORCHKRL_" does not exist in the ORDER CHECK")
+13 DO MES^XPDUTL(" RULE (#860.2) file.")
+14 QUIT
End DoDot:1
QUIT
+15 IF +$GET(^OCXS(860.2,ORCHKRLIEN,"INACT"))=ORACTIV
Begin DoDot:1
+16 DO BMES^XPDUTL(" "_ORCHKRL_" is already "_ORACT1_" ABORTING action!")
+17 QUIT
End DoDot:1
QUIT
+18 DO BMES^XPDUTL(ORACT_ORCHKRL_" in the ORDER CHECK")
+19 DO MES^XPDUTL(" RULE (#860.2) file.")
+20 SET ^OCXS(860.2,ORCHKRLIEN,"INACT")=ORACTIV
+21 DO BMES^XPDUTL(" "_ORCHKRL_" has been "_ORACT1)
+22 QUIT
+23 ;
RENAME(FILE,OROLD,ORNEW) ; Rename file entry
+1 NEW CNT,DA,DIC,DIE,DO,DR,FILENM,TEXT,X,Y
+2 if $GET(FILE)=""
QUIT
+3 if $GET(OROLD)=""
QUIT
+4 if $GET(ORNEW)=""
QUIT
+5 SET (DIC,DIE)=FILE
+6 SET DIC(0)="X"
+7 SET X=OROLD
+8 DO ^DIC
if Y<1
QUIT
+9 SET DA=+Y
+10 IF 'DA
QUIT
+11 SET DIE="^OCXS(860.3,"
SET DR=".01///"_ORNEW
+12 DO ^DIE
+13 SET FILENM=FILE
+14 SET DO=""
+15 DO DO^DIC1
+16 IF DO(2)'=-1
Begin DoDot:1
+17 SET FILENM=$PIECE(DO,U,1)_" (#"_$PIECE(DO,U,2)_")"
End DoDot:1
+18 SET CNT=1
+19 SET TEXT(CNT)="Renamed "_FILENM_" file entry "_OROLD_" to "_ORNEW_"."
+20 IF $LENGTH(TEXT(CNT))>66
Begin DoDot:1
+21 NEW DONE
+22 SET DONE=0
+23 SET X=$LENGTH(TEXT(CNT))
+24 FOR Y=66:-1:1
Begin DoDot:2
+25 IF $EXTRACT(TEXT(CNT),Y)'=" "
QUIT
+26 SET TEXT(CNT+1)=$EXTRACT(TEXT(CNT),Y+1,X)
+27 SET TEXT(CNT)=$EXTRACT(TEXT(CNT),1,Y)
+28 SET CNT=CNT+1
+29 IF $LENGTH(TEXT(CNT))<66
SET DONE=1
End DoDot:2
if DONE
QUIT
End DoDot:1
+30 SET CNT=1
+31 DO BMES^XPDUTL($GET(TEXT(CNT)))
+32 FOR
SET CNT=$ORDER(TEXT(CNT))
if +CNT=0
QUIT
DO MES^XPDUTL(" "_$GET(TEXT(CNT)))
+33 QUIT
RMVB ;Remove the bad "B" new-style field index in the NAME (#.01) field
+1 ; of the ORDER CHECK OVERRIDE REASONS (#100.04) file
+2 NEW MSG,OUTPUT
+3 DO BMES^XPDUTL("Deleting New-Style ""B"" index from the Data Dictionary for the")
+4 DO MES^XPDUTL("NAME (#.01) field in the ORDER CHECK OVERRIDE REASONS (#100.04) file ...")
+5 DO MES^XPDUTL("")
+6 DO DELIXN^DDMOD(100.04,"B","KW","OUTPUT","MSG")
+7 IF $DATA(MSG("DIERR"))
Begin DoDot:1
+8 NEW ERRCODE,ERRTXT,X,Y
+9 DO MES^XPDUTL(" An error occurred while deleting the New-Style ""B"" field index!!!")
+10 SET X=0
+11 FOR
SET X=$ORDER(MSG("DIERR",X))
if +X=0
QUIT
Begin DoDot:2
+12 SET ERRCODE=+$GET(MSG("DIERR",X))
+13 IF ERRCODE>0
DO MES^XPDUTL(" ERROR CODE: "_ERRCODE)
+14 SET Y=0
+15 FOR
SET Y=$ORDER(MSG("DIERR",X,"TEXT",Y))
if +Y=0
QUIT
Begin DoDot:3
+16 DO MES^XPDUTL(" "_$GET(MSG("DIERR",X,"TEXT",1)))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+17 DO BMES^XPDUTL(" Completed!")
+18 QUIT
+19 ;
REINDEX ;Reindex "B" cross reference in file 100.04
+1 NEW DIK
+2 DO BMES^XPDUTL("Reindexing the 'B' cross reference for file 100.04")
+3 SET DIK="^ORD(100.04,"
SET DIK(1)=".01"
+4 DO ENALL^DIK
+5 DO MES^XPDUTL(" Completed!")
+6 QUIT
+7 ;
RECOMPILE ;Recompile the Order Check System
+1 NEW OCXOETIM
+2 DO BMES^XPDUTL("---Recompiling Order Check Routines-----------------------------------")
+3 DO AUTO^OCXOCMP
+4 DO BMES^XPDUTL(" ---Recompiling Complete---")
+5 QUIT
+6 ;
RMVLCL ;Remove Local entries from the ORDER CHECK OVERRIDE REASONS (#100.04) file
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,CNT,DA,DIK
+2 ;S MSG(1)=" Patch OR*3*535 created an option to add local Order Check Override"
+3 ;S MSG(2)=" Reasons in file 100.04. Now that patch OR*3*535 is being backed out,"
+4 ;S MSG(3)=" you have the option to keep the locally created Order Check Override"
+5 ;S MSG(4)=" Reasons and by default the new NATIONAL (#.05) field. Answer YES to"
+6 ;S MSG(5)=" remove the local entries. Default response is NO."
+7 ;RMV1 ;S %=2,%Y=""
+8 ;D BMES^XPDUTL("Do you want to delete locally created Order Check Override Reasons in file 100.04")
+9 ;D YN^DICN
+10 ;D MES^XPDUTL(%Y)
RMV1 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+1 DO MES^XPDUTL("")
+2 IF DTIME>30
SET DIR("T")=30
+3 SET DIR("?",1)=" Patch OR*3*535 created an option to add local Order Check Override"
+4 SET DIR("?",2)=" Reasons in file 100.04. Now that patch OR*3*535 is being backed out,"
+5 SET DIR("?",3)=" you have the option to keep the locally created Order Check Override"
+6 SET DIR("?",4)=" Reasons and by default the new NATIONAL (#.05) field. Answer YES to"
+7 SET DIR("?")=" remove the local entries. Default response is NO."
+8 SET DIR(0)="Y"
+9 SET MSG(1)="Delete locally created Order Check Override Reasons in file 100.04."
+10 SET MSG(2)="Answering YES results in the NATIONAL (#.05) field in the ORDER CHECK"
+11 SET MSG(3)="OVERRIDE REASONS (#100.04) file to be removed as well. Proceed?"
+12 SET DIR("B")="NO"
+13 DO MES^XPDUTL(.MSG)
+14 DO ^DIR
+15 DO MES^XPDUTL($SELECT(Y=1:"YES",Y=0:"NO",Y="":"NO",1:Y))
+16 IF Y["^"
DO BMES^XPDUTL(" Exiting is not allowed!!")
DO MES^XPDUTL("")
GOTO RMV1
+17 IF +Y=0
Begin DoDot:1
+18 DO BMES^XPDUTL(" Skipping deletion of the locally created Order Check Override")
+19 DO MES^XPDUTL(" Reasons and leaving the new NATIONAL (#.05) field installed.")
End DoDot:1
QUIT
+20 ;I %<1 D
+21 ;. I %=0,%Y["?" D MES^XPDUTL(""),MES^XPDUTL(.MSG)
+22 ;. I %=-1 D BMES^XPDUTL(" Exiting is not allowed!!!")
+23 ;. G RMV1
+24 ;I %=2 D BMES^XPDUTL(" Skipping ...") Q
+25 DO BMES^XPDUTL("Removing local Order Check Override Reasons...")
+26 SET DIK="^ORD(100.04,"
+27 SET (CNT,DA)=0
+28 FOR
SET DA=$ORDER(^ORD(100.04,DA))
if +DA=0
QUIT
Begin DoDot:1
+29 IF +$PIECE($GET(^ORD(100.04,DA,0)),U,5)=1
QUIT
+30 DO MES^XPDUTL(" Deleting '"_$PIECE($GET(^ORD(100.04,DA,0)),U,1)_"'")
+31 DO ^DIK
+32 SET CNT=CNT+1
End DoDot:1
+33 DO BMES^XPDUTL(" --- "_CNT_" local Order Check Override Reasons removed!")
RMVNTL ;Remove National (#.05) field from the ORDER CHECK OVERRIDE REASONS (#100.04) file and any related data from file entries
+1 NEW OVRD,VAL4,VAL5
+2 DO BMES^XPDUTL("Removing NATIONAL (#.05) field from the ORDER CHECK OVERRIDE")
+3 DO MES^XPDUTL("REASONS (#100.04) file ...")
+4 SET DIK="^DD(100.04,"
+5 SET DA=.05
+6 SET DA(1)=100.04
+7 DO ^DIK
+8 SET OVRD=0
+9 FOR
SET OVRD=$ORDER(^ORD(100.04,OVRD))
if +OVRD=0
QUIT
Begin DoDot:1
+10 SET VAL5=$GET(^ORD(100.04,OVRD,0))
+11 SET VAL4=$PIECE(VAL5,U,1,4)
+12 IF VAL4=VAL5
QUIT
+13 SET ^ORD(100.04,OVRD,0)=VAL4
End DoDot:1
+14 DO BMES^XPDUTL(" ... COMPLETED!")
+15 QUIT
+16 ;
RMVPARAM ;Remove entries made related to the ORK METFORMIN EGFR parameter.
+1 NEW DA,DIK,ORENTITY,ORINSTANCE,ORPARAM
+2 SET ORPARAM=$ORDER(^XTV(8989.51,"B","ORK METFORMIN EGFR",""))
+3 IF ORPARAM<1
QUIT
+4 DO BMES^XPDUTL("Removing ORK METFORMIN EGFR parameter entries for all entities...")
+5 SET DIK="^XTV(8989.5,"
+6 SET ORENTITY=""
+7 FOR
SET ORENTITY=$ORDER(^XTV(8989.5,"AC",ORPARAM,ORENTITY))
if ORENTITY=""
QUIT
Begin DoDot:1
+8 SET ORINSTANCE=0
+9 FOR
SET ORINSTANCE=$ORDER(^XTV(8989.5,"AC",ORPARAM,ORENTITY,ORINSTANCE))
if +ORINSTANCE=0
QUIT
Begin DoDot:2
+10 SET DA=0
+11 FOR
SET DA=$ORDER(^XTV(8989.5,"AC",ORPARAM,ORENTITY,ORINSTANCE,DA))
if +DA=0
QUIT
Begin DoDot:3
+12 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+13 DO BMES^XPDUTL(" ... Complete!")
+14 QUIT
