Routine: ORY405

ORY405 ;SLC/JLC - ENVIRONMENTAL CHECK ROUTINE ;May 5, 2022@16:30:00

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211

PRE ;Preinstall routine for V32

 D INDPR^ORY405NV  ;IND

 D REMOPT

POST ;Post install routine for V32

 D RPSO,QQOPU

 D ORDRSN,OVRDRSN

 D MES^XPDUTL("")

 D EN^ORY405NV

 D INDPT^ORY405NV  ;IND

 D CLINMED^ORY405NV  ; Remove the Route and Days supply prompts from PSJ OR CLINIC OE

 D ADDMENU

 D PARS

 D RI10097

QQOPU ;

 N ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,TEXT,ZTSK

 S ZTDESC="Update to Outpatient Meds Quick Orders"

 S TEXT=ZTDESC_" has been queued, task number "

 S ZTRTN="QOPICKUP^ORY405"

 S ZTIO=""

 S ZTDTH=$$NOW^XLFDT

 D ^%ZTLOAD

 I $D(ZTSK) S TEXT=TEXT_ZTSK D MES^XPDUTL(.TEXT)

QOPICKUP ;Clean up any PICKUP entries in Quick Orders that are set to "C" for Clinic Pickup

 N ARRAY,DIALOG,INPUT,PROMPT,SUB

 K ^XTMP("OR PU QO LIST")

 S ^XTMP("OR PU QO LIST",0)=$$FMADD^XLFDT($$NOW^XLFDT,30)_U_$$NOW^XLFDT

 S PROMPT=$O(^ORD(101.41,"B","OR GTX ROUTING",""))

 S SUB="OR PU QO"

 K ^TMP($J,SUB)

 S INPUT("PSO OERR")=""

 D FINDQO^ORQOUTL(.ARRAY,.INPUT,SUB,0,1,0,0)

 S DIALOG="" F  S DIALOG=$O(^TMP($J,SUB,DIALOG)) Q:'DIALOG  D

 .I $D(^TMP($J,SUB,DIALOG,"ORDIALOG",PROMPT)) D

 ..I $G(^TMP($J,SUB,DIALOG,"ORDIALOG",PROMPT,1))'="C" Q

 ..D QOEMPTY(DIALOG,PROMPT)

 ..S ^XTMP("OR PU QO LIST","LIST",DIALOG)=""

 D QOREPORT

QOEMPTY(ORQO,ORPROMPT) ;Empty the prompt for this qo

 N ORSUB S ORSUB=$O(^ORD(101.41,ORQO,6,"D",ORPROMPT,""))

 S ^ORD(101.41,ORQO,6,ORSUB,1)=""

QOREPORT ;Send a mailman message of updated QOs

 K ^TMP("OR MSG",$J),XMY

 N CNT,XMDUZ,XMSUB,XMTEXT,XMY,XMMG

 S CNT=0,XMDUZ="CPRS, SEARCH",XMSUB="CLINIC PICKUP QUICK ORDER CONVERSION",XMTEXT="^TMP(""OR MSG"",$J,",XMY(DUZ)="",XMY("G.OR CACS")=""

 S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)="The following report lists Outpatient Medication Quick Orders where the "

 S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)="pickup was set to CLINIC.  These Quick Orders have had the pickup prompt "

 S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)="cleared of this value."

 S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)=""

 I $D(^XTMP("OR PU QO LIST")) D

 .N ORFLAG S ORFLAG=0

 .N ORI S ORI=0 F  S ORI=$O(^XTMP("OR PU QO LIST","LIST",ORI)) Q:'ORI  D

 ..I ORFLAG=0 D

 ...S ORFLAG=1

 ...S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)="QO NAME                       QO DISPLAY TEXT"

 ...S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)="==============================================================================="

 ..S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)=$$PAD^ORCHTAB($P(^ORD(101.41,ORI,0),U,1),30)_$P(^ORD(101.41,ORI,0),U,2)

 I CNT=4 S CNT=CNT+1,^TMP("OR MSG",$J,CNT,0)="None Found"

 D ^XMD

REMOPT ;

 D BMES^XPDUTL("Removing the following options from menu ORCM MGMT")

 I $$DELETE^XPDMENU("ORCM MGMT","OR SUPPLY UTIL MENU") D BMES^XPDUTL("  OR SUPPLY UTIL MENU")

 I $$DELETE^XPDMENU("ORCM MGMT","OR IV ADD FREQ UTILITY") D BMES^XPDUTL("  OR IV ADD FREQ UTILITY")

 I $$DELETE^XPDMENU("ORCM MGMT","OR QO FREETEXT REPORT") D BMES^XPDUTL("  OR QO FREETEXT REPORT")

 I $$DELETE^XPDMENU("ORCM MGMT","OR CONVERT INP TO IV") D BMES^XPDUTL("  OR CONVERT INP TO IV")

 I $$DELETE^XPDMENU("ORCM MGMT","OR CONV INPT QO TO CLIN ORD QO") D BMES^XPDUTL("  OR CONV INPT QO TO CLIN ORD QO")

 I $$DELETE^XPDMENU("ORCM MGMT","OR QO CASE REPORT") D BMES^XPDUTL("  OR QO CASE REPORT")

 I $$DELETE^XPDMENU("ORCM MGMT","OR MEDICATION QO CHECKER") D BMES^XPDUTL("  OR MEDICATION QO CHECKER")

 I $$DELETE^XPDMENU("ORCM MGMT","ORCM GMRC CSV CHECK") D BMES^XPDUTL("  ORCM GMRC CSV CHECK")

 I $$DELETE^XPDMENU("ORCM MGMT","ORCM UPD INDICATION QO") D BMES^XPDUTL("  ORCM UPD INDICATION QO")

 I $$DELETE^XPDMENU("ORCM MGMT","ORCM UPDATE TITRATION QO") D BMES^XPDUTL("  ORCM UPDATE TITRATION QO")

SENDDLG(ANAME) ; Return true if the current order dialog should be sent

 I ANAME="PSH OERR" Q 1

 I ANAME="PSO OERR" Q 1

 I ANAME="OR GTX ROUTING" Q 1

 I ANAME="OR GTX TITRATION" Q 1

Q 0

ORDRSN ;Add a new Order Reason of Allergy/Adverse Drug Reaction

 N DA,FDAMSG,FILE,ORERR,ORDRSN,ORFDA,ORSYN,ORACT,ORERR,ORPKG,ORNAT,ORIEN

 S ORIEN=""

 S FDAMSG=""

 S ORDRSN="Allergy/Adverse Drug Reaction"

 S ORSYN="ADR"

 S ORACT="ACTIVE"

 S ORPKG="ORDER ENTRY/RESULTS REPORTING"

 S ORNAT="REJECTED"

 S FILE=100.03

 D BMES^XPDUTL("Adding "_ORDRSN_" to ORDER REASON (#100.03) file.")

 S DA=$$FIND1^DIC(FILE,"","X",ORDRSN)

 I DA>0 D  ;Update existing entry

 . S ORFDA(100.03,DA_",",.01)=ORDRSN

 . S ORFDA(100.03,DA_",",.03)=ORSYN

 . S ORFDA(100.03,DA_",",.04)=ORACT

 . S ORFDA(100.03,DA_",",.05)=ORPKG

 . S ORFDA(100.03,DA_",",.07)=ORNAT

 . L +^ORD(100.03,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:5)

 . D FILE^DIE("E","ORFDA","FDAMSG")

 . L -^ORD(100.03,DA)

 . I $D(FDAMSG("DIERR")) D  Q

 .. N ERR,TEXT,SWTCH

 .. D BMES^XPDUTL("Failed to update entry "_ORDRSN_" (#"_DA_")!!")

 .. D MES^XPDUTL("     Please contact support!")

 .. S (ERR,SWTCH)=0 F  S ERR=$O(FDAMSG("DIERR",ERR)) Q:+ERR=0  D

 ... S TEXT=$G(FDAMSG("DIERR",ERR,"TEXT",1))

 ... I TEXT'="" D

 .... I SWTCH=0 S SWTCH=1 D MES^XPDUTL("Following error(s) were received:")

 .... D MES^XPDUTL("     "_TEXT)

 . D BMES^XPDUTL("Successfully updated "_ORDRSN_" (#"_DA_")!")

 . K FDAMSG

 I DA=0 D  ;Add new entry

 . N ERR,SWTCH

 . K FDAMSG

 . S FDAMSG=""

 . S ORFDA(100.03,"+1,",.01)=ORDRSN

 . S ORFDA(100.03,"+1,",.03)=ORSYN

 . S ORFDA(100.03,"+1,",.04)=ORACT

 . S ORFDA(100.03,"+1,",.05)=ORPKG

 . S ORFDA(100.03,"+1,",.07)=ORNAT

 . D UPDATE^DIE("E","ORFDA","ORIEN","FDAMSG")

 . I +ORIEN(1)>0 D

 .. D BMES^XPDUTL(ORDRSN_" has been successfully added to the")

 .. D MES^XPDUTL("     ORDER REASON (#100.03) file!")

 .. I $D(FDAMSG("DIERR")) D

 ... S (ERR,SWTCH)=0 F  S ERR=$O(FDAMSG("DIERR",ERR)) Q:+ERR=0  D

 .... S TEXT=$G(FDAMSG("DIERR",ERR,"TEXT",1))

 .... I TEXT'="" D

 ..... I SWTCH=0 S SWTCH=1 D MES^XPDUTL("     The Following error(s) were recorded, please contact support:")

 ..... D MES^XPDUTL("        "_TEXT)

 . I +ORIEN(1)<1 D

 .. D BMES^XPDUTL("Failed to add "_ORDRSN_"!!")

 .. D MES^XPDUTL("     Please contact support!")

 .. S (ERR,SWTCH)=0 F  S ERR=$O(FDAMSG("DIERR",ERR)) Q:+ERR=0  D

 ... S TEXT=$G(FDAMSG("DIERR",ERR,"TEXT",1))

 ... I TEXT'="" D

 .... I SWTCH=0 S SWTCH=1 D MES^XPDUTL("Following error(s) were received:")

 .... D MES^XPDUTL("     "_TEXT)

 . K FDAMSG

 I DA="" D  ;Failure

 . D BMES^XPDUTL("Failed to add "_ORDRSN_"!!")

 . D MES^XPDUTL("     Please contact support!")

 D BMES^XPDUTL("")

OVRDRSN ;Add the Order Check Override Reasons (#100.04) file entries

 N ACTIVE,DA,FAILURE,FDA,FDAIEN,FDAMSG,FILE,LINE,MSG,NAME,ORERR,SUCCESS

 N SYNONYM,TEXT,TYPE

 S FAILURE="     Failed to add the following entry, please contact support:"

 S SUCCESS="     SUCCESSFULLY ADDED: "

 D BMES^XPDUTL("Starting add/update of the ORDER CHECK OVERRIDE REASON (#100.04) file.")

 D MES^XPDUTL("")

 S FILE=100.04

 F LINE=1:1 Q:$L($T(ORDRCHK+LINE))<3  D

 . K FDA,FDAIEN,FDAMSG,MSG,ORERR

 . S FDAIEN(1)=LINE

 . S FDAMSG=""

 . S TEXT=$P($T(ORDRCHK+LINE),";;",2)

 . S NAME=$P(TEXT,U,1)

 . S SYNONYM=$P(TEXT,U,2)

 . S TYPE=$P(TEXT,U,3)

 . S ACTIVE=$P(TEXT,U,4)

 . S DA=$$FIND1^DIC(FILE,,"X",NAME)

 . S MSG(2)="          "_$S($L(NAME," ")>8:$P(NAME," ",1,8),1:NAME)

 . I $L(NAME," ")>8 S MSG(3)="          "_$P(NAME," ",9,9999)

 . I DA>0 D  Q  ;Update existing entry

 .. S FDA(100.04,DA_",",.01)=NAME

 .. S FDA(100.04,DA_",",.02)=SYNONYM

 .. S FDA(100.04,DA_",",.03)=TYPE

 .. S FDA(100.04,DA_",",.04)=ACTIVE

 .. L +^ORD(100.04,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:5)

 .. D FILE^DIE("E","FDA","FDAMSG")

 .. L -^ORD(100.04,DA)

 .. I $D(FDAMSG("DIERR")) D  Q

 ... N ERR,MSGCNT,SWTCH

 ... S MSG(1)="     Failed to update entry #"_DA_":"

 ... S (ERR,SWTCH)=0 F  S ERR=$O(FDAMSG("DIERR",ERR)) Q:+ERR=0  D

 .... S TEXT=$G(FDAMSG("DIERR",ERR,"TEXT",1))

 .... I TEXT'="" D

 ..... I SWTCH=0 D

 ...... S SWTCH=1,MSGCNT=3

 ...... I $D(MSG(3)) S MSGCNT=4

 ...... S MSG(MSGCNT)="        Following errors were received:"

 ...... S MSGCNT=MSGCNT+1

 ..... S MSG(MSGCNT)="           "_TEXT

 ... D BMES^XPDUTL(.MSG)

 .. S MSG(1)="     Successfully updated entry #"_DA_":"

 .. D BMES^XPDUTL(.MSG)

 . I DA=0 D  Q  ;Add new entry

 .. S FDA(100.04,"+1,",.01)=NAME

 .. S FDA(100.04,"+1,",.02)=SYNONYM

 .. S FDA(100.04,"+1,",.03)=TYPE

 .. S FDA(100.04,"+1,",.04)=ACTIVE

 .. D UPDATE^DIE("","FDA","FDAIEN","FDAMSG")

 .. I +FDAIEN(1)>0 D

 ... S MSG(1)=SUCCESS

 .. I +FDAIEN(1)<1 D

 ... N ERR,MSGCNT,SWTCH

 ... S MSG(1)=FAILURE

 ... S (ERR,SWTCH)=0 F  S ERR=$O(FDAMSG("DIERR",ERR)) Q:+ERR=0  D

 .... S TEXT=$G(FDAMSG("DIERR",ERR,"TEXT",1))

 .... I TEXT'="" D

 ..... I SWTCH=0 D

 ...... S SWTCH=1,MSGCNT=3

 ...... I $D(MSG(3)) S MSGCNT=4

 ...... S MSG(MSGCNT)="        Following errors were received:"

 ...... S MSGCNT=MSGCNT+1

 ..... S MSG(MSGCNT)="           "_TEXT

 .. D BMES^XPDUTL(.MSG)

 . I DA="" D  ;Failure

 .. S MSG(1)=FAILURE

 .. D BMES^XPDUTL(.MSG)

 D BMES^XPDUTL("COMPLETED add/update of the ORDER CHECK OVERRIDE REASON (#100.04) file.")

ORDRCHK ;Order Check Override Reasons

 ;;Benefit of Therapy Outweighs Risk^BEN^B^1

 ;;Patient tolerating current therapy with this medication^PAT^B^1

 ;;Previous Adverse Reaction signs/symptoms managed by patient^PRE^B^1

 ;;Renewal of Current Therapy^REN^B^1

 ;;Will Monitor Closely for Adverse Effects^WILL^B^1

 ;;Documentation of Allergy/Adverse Reaction is in Error^DOCAA^B^1

 ;;Documentation of Allergy/Adverse Reaction is to different agent in same drug class^DOAD^B^1

 ;;Patient report per interview is inconsistent with remote allergy data.^REM^B^1

RPSO ;remove package PSO from the DONE entry in file #101.42

 D BMES^XPDUTL("Removing PSO from the entry DONE of the ORDER URGENCY (#101.42) file.")

 N IEN,DA,DIK

 S IEN=$O(^ORD(101.42,"S.PSO","DONE",""))

 Q:'IEN

 S DA=0 F  S DA=$O(^ORD(101.42,IEN,1,DA)) Q:'DA  I ^(DA,0)="PSO" D  Q

 .S DA(1)=IEN,DIK="^ORD(101.42,"_DA(1)_",1," D ^DIK Q

ADDMENU ;

 N ORSUCC,OROPT

 D BMES^XPDUTL("Adding the following options to menu OR VIMM MENU")

 F OROPT="PXV EDIT SEQUENCE^SEQ^20","PXV EDIT DEFAULT RESPONSES^DEF^22","PXV SKIN TEST READING CPT^SKC^40" D

 . S ORSUCC=$$ADD^XPDMENU("OR VIMM MENU",$P(OROPT,U,1),$P(OROPT,U,2),$P(OROPT,U,3))

 . I ORSUCC D BMES^XPDUTL("  "_$P(OROPT,U,1))

 . I 'ORSUCC D BMES^XPDUTL("  Error adding "_$P(OROPT,U,1)_" to OR VIMM MENU.")

 D BMES^XPDUTL("Adding the following options to menu ORCM REPORT/CONV UTILITIES")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","ORCM GMRC CSV CHECK","CS",5) D BMES^XPDUTL("  ORCM GMRC CSV CHECK")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR MEDICATION QO CHECKER","MR",10) D BMES^XPDUTL("  OR MEDICATION QO CHECKER")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR QO CASE REPORT","CA",25) D BMES^XPDUTL("  OR QO CASE REPORT")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR CONV INPT QO TO CLIN ORD QO","CO",30) D BMES^XPDUTL("  OR CONV INPT QO TO CLIN ORD QO")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR CONVERT INP TO IV","CV",35) D BMES^XPDUTL("  OR CONVERT INP TO IV")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR QO FREETEXT REPORT","DF",40) D BMES^XPDUTL("  OR QO FREETEXT REPORT")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR IV ADD FREQ UTILITY","FR",45) D BMES^XPDUTL("  OR IV ADD FREQ UTILITY")

 I $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR SUPPLY UTIL MENU","SP",50) D BMES^XPDUTL("  OR SUPPLY UTIL MENU")

PARS ; set Parameter values

 N ORINST,ORLIST,ORI,ORX,ORIMM,ORIMMS,ORERR

 D BMES^XPDUTL("Setting OR IMM REMINDER DIALOG values.")

 S ORINST=0  ;largest instance

 D GETLST^XPAR(.ORLIST,"SYS","OR IMM REMINDER DIALOG")

 S ORI=0

 F  S ORI=$O(ORLIST(ORI)) Q:'ORI  D

 . S ORX=$G(ORLIST(ORI))

 . I $P(ORX,U,2)="" Q

 . S ORIMMS($P(ORX,U,2))=""  ; list of immunizations already defined

 . I $P(ORX,U,1)>ORINST S ORINST=$P(ORX,U,1)

 ; See if other COVID-19 Imms need to be added

 S ORIMM=0

 F  S ORIMM=$O(^AUTTIMM(ORIMM)) Q:'ORIMM  D   ;ICR  1990

 . S ORX=$G(^AUTTIMM(ORIMM,0))

 . I $P(ORX,U,1)'["COVID-19" Q

 . I $P(ORX,U,3)'=211,$P(ORX,U,7) Q  ;exclude inactive (except Novavax)

 . I $D(ORIMMS(ORIMM)) Q  ;already defined

 . S ORINST=ORINST+1

 . K ORERR

 . D EN^XPAR("SYS","OR IMM REMINDER DIALOG",ORINST,"`"_ORIMM,.ORERR)

 . I +$G(ORERR)>0 D MES^XPDUTL("  ERROR #"_$P(ORERR,U)_": "_$P(ORERR,U,2))

 D MES^XPDUTL("  DONE")

 D BMES^XPDUTL("Setting OR RTN PROCESSED ALERTS value.")

 I $$GET^XPAR("SYS","OR RTN PROCESSED ALERTS")]"" D BMES^XPDUTL("OR RTN PROCESSED ALERTS value is already set") Q

 K ORERR

 D EN^XPAR("SYS","OR RTN PROCESSED ALERTS",1,"YES",.ORERR)

 I +$G(ORERR)>0 D MES^XPDUTL("  ERROR #"_$P(ORERR,U)_": "_$P(ORERR,U,2))

 D MES^XPDUTL("  DONE")

RI10097 ;;re-index 100.97

 N DIK

 D BMES^XPDUTL("Re-indexing 100.97, 'E' cross-reference...")

 K ^OR(100.97,"E")

 S DIK="^OR(100.97,",DIK(1)="8^E" D ENALL^DIK

 D BMES^XPDUTL("Completed re-indexing of 100.97")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY405   13044     printed  Feb 19, 2025@00:08:19                                                                                                                                                                                                     Page 2

ORY405    ;SLC/JLC - ENVIRONMENTAL CHECK ROUTINE ;May 5, 2022@16:30:00

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211

 +2       ;

PRE       ;Preinstall routine for V32

 +1       ;IND

           DO INDPR^ORY405NV

 +2        DO REMOPT

 +3        QUIT

 +4       ;

POST      ;Post install routine for V32

 +1        DO RPSO

           DO QQOPU

 +2        DO ORDRSN

           DO OVRDRSN

 +3        DO MES^XPDUTL("")

 +4        DO EN^ORY405NV

 +5       ;IND

           DO INDPT^ORY405NV

 +6       ; Remove the Route and Days supply prompts from PSJ OR CLINIC OE

           DO CLINMED^ORY405NV

 +7        DO ADDMENU

 +8        DO PARS

 +9        DO RI10097

 +10       QUIT

 +11      ;

QQOPU     ;

 +1        NEW ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,TEXT,ZTSK

 +2        SET ZTDESC="Update to Outpatient Meds Quick Orders"

 +3        SET TEXT=ZTDESC_" has been queued, task number "

 +4        SET ZTRTN="QOPICKUP^ORY405"

 +5        SET ZTIO=""

 +6        SET ZTDTH=$$NOW^XLFDT

 +7        DO ^%ZTLOAD

 +8        IF $DATA(ZTSK)

               SET TEXT=TEXT_ZTSK

               DO MES^XPDUTL(.TEXT)

 +9        QUIT

 +10      ;

QOPICKUP  ;Clean up any PICKUP entries in Quick Orders that are set to "C" for Clinic Pickup

 +1        NEW ARRAY,DIALOG,INPUT,PROMPT,SUB

 +2        KILL ^XTMP("OR PU QO LIST")

 +3        SET ^XTMP("OR PU QO LIST",0)=$$FMADD^XLFDT($$NOW^XLFDT,30)_U_$$NOW^XLFDT

 +4        SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ROUTING",""))

 +5        SET SUB="OR PU QO"

 +6        KILL ^TMP($JOB,SUB)

 +7        SET INPUT("PSO OERR")=""

 +8        DO FINDQO^ORQOUTL(.ARRAY,.INPUT,SUB,0,1,0,0)

 +9        SET DIALOG=""

FOR

               SET DIALOG=$ORDER(^TMP($JOB,SUB,DIALOG))

               if 'DIALOG

                   QUIT

               Begin DoDot:1

 +10               IF $DATA(^TMP($JOB,SUB,DIALOG,"ORDIALOG",PROMPT))

                       Begin DoDot:2

 +11                       IF $GET(^TMP($JOB,SUB,DIALOG,"ORDIALOG",PROMPT,1))'="C"

                               QUIT

 +12                       DO QOEMPTY(DIALOG,PROMPT)

 +13                       SET ^XTMP("OR PU QO LIST","LIST",DIALOG)=""

                       End DoDot:2

               End DoDot:1

 +14       DO QOREPORT

 +15       QUIT

 +16      ;

QOEMPTY(ORQO,ORPROMPT) ;Empty the prompt for this qo

 +1        NEW ORSUB

           SET ORSUB=$ORDER(^ORD(101.41,ORQO,6,"D",ORPROMPT,""))

 +2        SET ^ORD(101.41,ORQO,6,ORSUB,1)=""

 +3        QUIT

 +4       ;

QOREPORT  ;Send a mailman message of updated QOs

 +1        KILL ^TMP("OR MSG",$JOB),XMY

 +2        NEW CNT,XMDUZ,XMSUB,XMTEXT,XMY,XMMG

 +3        SET CNT=0

           SET XMDUZ="CPRS, SEARCH"

           SET XMSUB="CLINIC PICKUP QUICK ORDER CONVERSION"

           SET XMTEXT="^TMP(""OR MSG"",$J,"

           SET XMY(DUZ)=""

           SET XMY("G.OR CACS")=""

 +4        SET CNT=CNT+1

           SET ^TMP("OR MSG",$JOB,CNT,0)="The following report lists Outpatient Medication Quick Orders where the "

 +5        SET CNT=CNT+1

           SET ^TMP("OR MSG",$JOB,CNT,0)="pickup was set to CLINIC.  These Quick Orders have had the pickup prompt "

 +6        SET CNT=CNT+1

           SET ^TMP("OR MSG",$JOB,CNT,0)="cleared of this value."

 +7        SET CNT=CNT+1

           SET ^TMP("OR MSG",$JOB,CNT,0)=""

 +8        IF $DATA(^XTMP("OR PU QO LIST"))

               Begin DoDot:1

 +9                NEW ORFLAG

                   SET ORFLAG=0

 +10               NEW ORI

                   SET ORI=0

FOR

                       SET ORI=$ORDER(^XTMP("OR PU QO LIST","LIST",ORI))

                       if 'ORI

                           QUIT

                       Begin DoDot:2

 +11                       IF ORFLAG=0

                               Begin DoDot:3

 +12                               SET ORFLAG=1

 +13                               SET CNT=CNT+1

                                   SET ^TMP("OR MSG",$JOB,CNT,0)="QO NAME                       QO DISPLAY TEXT"

 +14                               SET CNT=CNT+1

                                   SET ^TMP("OR MSG",$JOB,CNT,0)="==============================================================================="

                               End DoDot:3

 +15                       SET CNT=CNT+1

                           SET ^TMP("OR MSG",$JOB,CNT,0)=$$PAD^ORCHTAB($PIECE(^ORD(101.41,ORI,0),U,1),30)_$PIECE(^ORD(101.41,ORI,0),U,2)

                       End DoDot:2

               End DoDot:1

 +16       IF CNT=4

               SET CNT=CNT+1

               SET ^TMP("OR MSG",$JOB,CNT,0)="None Found"

 +17       DO ^XMD

 +18       QUIT

 +19      ;

REMOPT    ;

 +1        DO BMES^XPDUTL("Removing the following options from menu ORCM MGMT")

 +2        IF $$DELETE^XPDMENU("ORCM MGMT","OR SUPPLY UTIL MENU")

               DO BMES^XPDUTL("  OR SUPPLY UTIL MENU")

 +3        IF $$DELETE^XPDMENU("ORCM MGMT","OR IV ADD FREQ UTILITY")

               DO BMES^XPDUTL("  OR IV ADD FREQ UTILITY")

 +4        IF $$DELETE^XPDMENU("ORCM MGMT","OR QO FREETEXT REPORT")

               DO BMES^XPDUTL("  OR QO FREETEXT REPORT")

 +5        IF $$DELETE^XPDMENU("ORCM MGMT","OR CONVERT INP TO IV")

               DO BMES^XPDUTL("  OR CONVERT INP TO IV")

 +6        IF $$DELETE^XPDMENU("ORCM MGMT","OR CONV INPT QO TO CLIN ORD QO")

               DO BMES^XPDUTL("  OR CONV INPT QO TO CLIN ORD QO")

 +7        IF $$DELETE^XPDMENU("ORCM MGMT","OR QO CASE REPORT")

               DO BMES^XPDUTL("  OR QO CASE REPORT")

 +8        IF $$DELETE^XPDMENU("ORCM MGMT","OR MEDICATION QO CHECKER")

               DO BMES^XPDUTL("  OR MEDICATION QO CHECKER")

 +9        IF $$DELETE^XPDMENU("ORCM MGMT","ORCM GMRC CSV CHECK")

               DO BMES^XPDUTL("  ORCM GMRC CSV CHECK")

 +10       IF $$DELETE^XPDMENU("ORCM MGMT","ORCM UPD INDICATION QO")

               DO BMES^XPDUTL("  ORCM UPD INDICATION QO")

 +11       IF $$DELETE^XPDMENU("ORCM MGMT","ORCM UPDATE TITRATION QO")

               DO BMES^XPDUTL("  ORCM UPDATE TITRATION QO")

 +12       QUIT

 +13      ;

SENDDLG(ANAME) ; Return true if the current order dialog should be sent

 +1        IF ANAME="PSH OERR"

               QUIT 1

 +2        IF ANAME="PSO OERR"

               QUIT 1

 +3        IF ANAME="OR GTX ROUTING"

               QUIT 1

 +4        IF ANAME="OR GTX TITRATION"

               QUIT 1

 +5        QUIT 0

 +6       ;

ORDRSN    ;Add a new Order Reason of Allergy/Adverse Drug Reaction

 +1        NEW DA,FDAMSG,FILE,ORERR,ORDRSN,ORFDA,ORSYN,ORACT,ORERR,ORPKG,ORNAT,ORIEN

 +2        SET ORIEN=""

 +3        SET FDAMSG=""

 +4        SET ORDRSN="Allergy/Adverse Drug Reaction"

 +5        SET ORSYN="ADR"

 +6        SET ORACT="ACTIVE"

 +7        SET ORPKG="ORDER ENTRY/RESULTS REPORTING"

 +8        SET ORNAT="REJECTED"

 +9        SET FILE=100.03

 +10       DO BMES^XPDUTL("Adding "_ORDRSN_" to ORDER REASON (#100.03) file.")

 +11       SET DA=$$FIND1^DIC(FILE,"","X",ORDRSN)

 +12      ;Update existing entry

           IF DA>0

               Begin DoDot:1

 +13               SET ORFDA(100.03,DA_",",.01)=ORDRSN

 +14               SET ORFDA(100.03,DA_",",.03)=ORSYN

 +15               SET ORFDA(100.03,DA_",",.04)=ORACT

 +16               SET ORFDA(100.03,DA_",",.05)=ORPKG

 +17               SET ORFDA(100.03,DA_",",.07)=ORNAT

 +18               LOCK +^ORD(100.03,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)

 +19               DO FILE^DIE("E","ORFDA","FDAMSG")

 +20               LOCK -^ORD(100.03,DA)

 +21               IF $DATA(FDAMSG("DIERR"))

                       Begin DoDot:2

 +22                       NEW ERR,TEXT,SWTCH

 +23                       DO BMES^XPDUTL("Failed to update entry "_ORDRSN_" (#"_DA_")!!")

 +24                       DO MES^XPDUTL("     Please contact support!")

 +25                       SET (ERR,SWTCH)=0

FOR

                               SET ERR=$ORDER(FDAMSG("DIERR",ERR))

                               if +ERR=0

                                   QUIT

                               Begin DoDot:3

 +26                               SET TEXT=$GET(FDAMSG("DIERR",ERR,"TEXT",1))

 +27                               IF TEXT'=""

                                       Begin DoDot:4

 +28                                       IF SWTCH=0

                                               SET SWTCH=1

                                               DO MES^XPDUTL("Following error(s) were received:")

 +29                                       DO MES^XPDUTL("     "_TEXT)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

                       QUIT

 +30               DO BMES^XPDUTL("Successfully updated "_ORDRSN_" (#"_DA_")!")

 +31               KILL FDAMSG

               End DoDot:1

 +32      ;Add new entry

           IF DA=0

               Begin DoDot:1

 +33               NEW ERR,SWTCH

 +34               KILL FDAMSG

 +35               SET FDAMSG=""

 +36               SET ORFDA(100.03,"+1,",.01)=ORDRSN

 +37               SET ORFDA(100.03,"+1,",.03)=ORSYN

 +38               SET ORFDA(100.03,"+1,",.04)=ORACT

 +39               SET ORFDA(100.03,"+1,",.05)=ORPKG

 +40               SET ORFDA(100.03,"+1,",.07)=ORNAT

 +41               DO UPDATE^DIE("E","ORFDA","ORIEN","FDAMSG")

 +42               IF +ORIEN(1)>0

                       Begin DoDot:2

 +43                       DO BMES^XPDUTL(ORDRSN_" has been successfully added to the")

 +44                       DO MES^XPDUTL("     ORDER REASON (#100.03) file!")

 +45                       IF $DATA(FDAMSG("DIERR"))

                               Begin DoDot:3

 +46                               SET (ERR,SWTCH)=0

FOR

                                       SET ERR=$ORDER(FDAMSG("DIERR",ERR))

                                       if +ERR=0

                                           QUIT

                                       Begin DoDot:4

 +47                                       SET TEXT=$GET(FDAMSG("DIERR",ERR,"TEXT",1))

 +48                                       IF TEXT'=""

                                               Begin DoDot:5

 +49                                               IF SWTCH=0

                                                       SET SWTCH=1

                                                       DO MES^XPDUTL("     The Following error(s) were recorded, please contact support:")

 +50                                               DO MES^XPDUTL("        "_TEXT)

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

 +51               IF +ORIEN(1)<1

                       Begin DoDot:2

 +52                       DO BMES^XPDUTL("Failed to add "_ORDRSN_"!!")

 +53                       DO MES^XPDUTL("     Please contact support!")

 +54                       SET (ERR,SWTCH)=0

FOR

                               SET ERR=$ORDER(FDAMSG("DIERR",ERR))

                               if +ERR=0

                                   QUIT

                               Begin DoDot:3

 +55                               SET TEXT=$GET(FDAMSG("DIERR",ERR,"TEXT",1))

 +56                               IF TEXT'=""

                                       Begin DoDot:4

 +57                                       IF SWTCH=0

                                               SET SWTCH=1

                                               DO MES^XPDUTL("Following error(s) were received:")

 +58                                       DO MES^XPDUTL("     "_TEXT)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

 +59               KILL FDAMSG

               End DoDot:1

 +60      ;Failure

           IF DA=""

               Begin DoDot:1

 +61               DO BMES^XPDUTL("Failed to add "_ORDRSN_"!!")

 +62               DO MES^XPDUTL("     Please contact support!")

               End DoDot:1

 +63       DO BMES^XPDUTL("")

 +64       QUIT

 +65      ;

OVRDRSN   ;Add the Order Check Override Reasons (#100.04) file entries

 +1        NEW ACTIVE,DA,FAILURE,FDA,FDAIEN,FDAMSG,FILE,LINE,MSG,NAME,ORERR,SUCCESS

 +2        NEW SYNONYM,TEXT,TYPE

 +3        SET FAILURE="     Failed to add the following entry, please contact support:"

 +4        SET SUCCESS="     SUCCESSFULLY ADDED: "

 +5        DO BMES^XPDUTL("Starting add/update of the ORDER CHECK OVERRIDE REASON (#100.04) file.")

 +6        DO MES^XPDUTL("")

 +7        SET FILE=100.04

 +8        FOR LINE=1:1

               if $LENGTH($TEXT(ORDRCHK+LINE))<3

                   QUIT

               Begin DoDot:1

 +9                KILL FDA,FDAIEN,FDAMSG,MSG,ORERR

 +10               SET FDAIEN(1)=LINE

 +11               SET FDAMSG=""

 +12               SET TEXT=$PIECE($TEXT(ORDRCHK+LINE),";;",2)

 +13               SET NAME=$PIECE(TEXT,U,1)

 +14               SET SYNONYM=$PIECE(TEXT,U,2)

 +15               SET TYPE=$PIECE(TEXT,U,3)

 +16               SET ACTIVE=$PIECE(TEXT,U,4)

 +17               SET DA=$$FIND1^DIC(FILE,,"X",NAME)

 +18               SET MSG(2)="          "_$SELECT($LENGTH(NAME," ")>8:$PIECE(NAME," ",1,8),1:NAME)

 +19               IF $LENGTH(NAME," ")>8

                       SET MSG(3)="          "_$PIECE(NAME," ",9,9999)

 +20      ;Update existing entry

                   IF DA>0

                       Begin DoDot:2

 +21                       SET FDA(100.04,DA_",",.01)=NAME

 +22                       SET FDA(100.04,DA_",",.02)=SYNONYM

 +23                       SET FDA(100.04,DA_",",.03)=TYPE

 +24                       SET FDA(100.04,DA_",",.04)=ACTIVE

 +25                       LOCK +^ORD(100.04,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)

 +26                       DO FILE^DIE("E","FDA","FDAMSG")

 +27                       LOCK -^ORD(100.04,DA)

 +28                       IF $DATA(FDAMSG("DIERR"))

                               Begin DoDot:3

 +29                               NEW ERR,MSGCNT,SWTCH

 +30                               SET MSG(1)="     Failed to update entry #"_DA_":"

 +31                               SET (ERR,SWTCH)=0

FOR

                                       SET ERR=$ORDER(FDAMSG("DIERR",ERR))

                                       if +ERR=0

                                           QUIT

                                       Begin DoDot:4

 +32                                       SET TEXT=$GET(FDAMSG("DIERR",ERR,"TEXT",1))

 +33                                       IF TEXT'=""

                                               Begin DoDot:5

 +34                                               IF SWTCH=0

                                                       Begin DoDot:6

 +35                                                       SET SWTCH=1

                                                           SET MSGCNT=3

 +36                                                       IF $DATA(MSG(3))

                                                               SET MSGCNT=4

 +37                                                       SET MSG(MSGCNT)="        Following errors were received:"

 +38                                                       SET MSGCNT=MSGCNT+1

                                                       End DoDot:6

 +39                                               SET MSG(MSGCNT)="           "_TEXT

                                               End DoDot:5

                                       End DoDot:4

 +40                               DO BMES^XPDUTL(.MSG)

                               End DoDot:3

                               QUIT

 +41                       SET MSG(1)="     Successfully updated entry #"_DA_":"

 +42                       DO BMES^XPDUTL(.MSG)

                       End DoDot:2

                       QUIT

 +43      ;Add new entry

                   IF DA=0

                       Begin DoDot:2

 +44                       SET FDA(100.04,"+1,",.01)=NAME

 +45                       SET FDA(100.04,"+1,",.02)=SYNONYM

 +46                       SET FDA(100.04,"+1,",.03)=TYPE

 +47                       SET FDA(100.04,"+1,",.04)=ACTIVE

 +48                       DO UPDATE^DIE("","FDA","FDAIEN","FDAMSG")

 +49                       IF +FDAIEN(1)>0

                               Begin DoDot:3

 +50                               SET MSG(1)=SUCCESS

                               End DoDot:3

 +51                       IF +FDAIEN(1)<1

                               Begin DoDot:3

 +52                               NEW ERR,MSGCNT,SWTCH

 +53                               SET MSG(1)=FAILURE

 +54                               SET (ERR,SWTCH)=0

FOR

                                       SET ERR=$ORDER(FDAMSG("DIERR",ERR))

                                       if +ERR=0

                                           QUIT

                                       Begin DoDot:4

 +55                                       SET TEXT=$GET(FDAMSG("DIERR",ERR,"TEXT",1))

 +56                                       IF TEXT'=""

                                               Begin DoDot:5

 +57                                               IF SWTCH=0

                                                       Begin DoDot:6

 +58                                                       SET SWTCH=1

                                                           SET MSGCNT=3

 +59                                                       IF $DATA(MSG(3))

                                                               SET MSGCNT=4

 +60                                                       SET MSG(MSGCNT)="        Following errors were received:"

 +61                                                       SET MSGCNT=MSGCNT+1

                                                       End DoDot:6

 +62                                               SET MSG(MSGCNT)="           "_TEXT

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

 +63                       DO BMES^XPDUTL(.MSG)

                       End DoDot:2

                       QUIT

 +64      ;Failure

                   IF DA=""

                       Begin DoDot:2

 +65                       SET MSG(1)=FAILURE

 +66                       DO BMES^XPDUTL(.MSG)

                       End DoDot:2

               End DoDot:1

 +67       DO BMES^XPDUTL("COMPLETED add/update of the ORDER CHECK OVERRIDE REASON (#100.04) file.")

 +68       QUIT

 +69      ;

ORDRCHK   ;Order Check Override Reasons

 +1       ;;Benefit of Therapy Outweighs Risk^BEN^B^1

 +2       ;;Patient tolerating current therapy with this medication^PAT^B^1

 +3       ;;Previous Adverse Reaction signs/symptoms managed by patient^PRE^B^1

 +4       ;;Renewal of Current Therapy^REN^B^1

 +5       ;;Will Monitor Closely for Adverse Effects^WILL^B^1

 +6       ;;Documentation of Allergy/Adverse Reaction is in Error^DOCAA^B^1

 +7       ;;Documentation of Allergy/Adverse Reaction is to different agent in same drug class^DOAD^B^1

 +8       ;;Patient report per interview is inconsistent with remote allergy data.^REM^B^1

 +9        QUIT

 +10      ;

RPSO      ;remove package PSO from the DONE entry in file #101.42

 +1        DO BMES^XPDUTL("Removing PSO from the entry DONE of the ORDER URGENCY (#101.42) file.")

 +2        NEW IEN,DA,DIK

 +3        SET IEN=$ORDER(^ORD(101.42,"S.PSO","DONE",""))

 +4        if 'IEN

               QUIT

 +5        SET DA=0

FOR

               SET DA=$ORDER(^ORD(101.42,IEN,1,DA))

               if 'DA

                   QUIT

               IF ^(DA,0)="PSO"

                   Begin DoDot:1

 +6                    SET DA(1)=IEN

                       SET DIK="^ORD(101.42,"_DA(1)_",1,"

                       DO ^DIK

                       QUIT

                   End DoDot:1

                   QUIT

 +7        QUIT

 +8       ;

ADDMENU   ;

 +1        NEW ORSUCC,OROPT

 +2       ;

 +3        DO BMES^XPDUTL("Adding the following options to menu OR VIMM MENU")

 +4        FOR OROPT="PXV EDIT SEQUENCE^SEQ^20","PXV EDIT DEFAULT RESPONSES^DEF^22","PXV SKIN TEST READING CPT^SKC^40"

               Begin DoDot:1

 +5                SET ORSUCC=$$ADD^XPDMENU("OR VIMM MENU",$PIECE(OROPT,U,1),$PIECE(OROPT,U,2),$PIECE(OROPT,U,3))

 +6                IF ORSUCC

                       DO BMES^XPDUTL("  "_$PIECE(OROPT,U,1))

 +7                IF 'ORSUCC

                       DO BMES^XPDUTL("  Error adding "_$PIECE(OROPT,U,1)_" to OR VIMM MENU.")

               End DoDot:1

 +8       ;

 +9        DO BMES^XPDUTL("Adding the following options to menu ORCM REPORT/CONV UTILITIES")

 +10       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","ORCM GMRC CSV CHECK","CS",5)

               DO BMES^XPDUTL("  ORCM GMRC CSV CHECK")

 +11       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR MEDICATION QO CHECKER","MR",10)

               DO BMES^XPDUTL("  OR MEDICATION QO CHECKER")

 +12       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR QO CASE REPORT","CA",25)

               DO BMES^XPDUTL("  OR QO CASE REPORT")

 +13       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR CONV INPT QO TO CLIN ORD QO","CO",30)

               DO BMES^XPDUTL("  OR CONV INPT QO TO CLIN ORD QO")

 +14       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR CONVERT INP TO IV","CV",35)

               DO BMES^XPDUTL("  OR CONVERT INP TO IV")

 +15       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR QO FREETEXT REPORT","DF",40)

               DO BMES^XPDUTL("  OR QO FREETEXT REPORT")

 +16       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR IV ADD FREQ UTILITY","FR",45)

               DO BMES^XPDUTL("  OR IV ADD FREQ UTILITY")

 +17       IF $$ADD^XPDMENU("ORCM REPORT/CONV UTILITIES","OR SUPPLY UTIL MENU","SP",50)

               DO BMES^XPDUTL("  OR SUPPLY UTIL MENU")

 +18       QUIT

 +19      ;

PARS      ; set Parameter values

 +1       ;

 +2        NEW ORINST,ORLIST,ORI,ORX,ORIMM,ORIMMS,ORERR

 +3       ;

 +4        DO BMES^XPDUTL("Setting OR IMM REMINDER DIALOG values.")

 +5       ;largest instance

           SET ORINST=0

 +6        DO GETLST^XPAR(.ORLIST,"SYS","OR IMM REMINDER DIALOG")

 +7        SET ORI=0

 +8        FOR

               SET ORI=$ORDER(ORLIST(ORI))

               if 'ORI

                   QUIT

               Begin DoDot:1

 +9                SET ORX=$GET(ORLIST(ORI))

 +10               IF $PIECE(ORX,U,2)=""

                       QUIT

 +11      ; list of immunizations already defined

                   SET ORIMMS($PIECE(ORX,U,2))=""

 +12               IF $PIECE(ORX,U,1)>ORINST

                       SET ORINST=$PIECE(ORX,U,1)

               End DoDot:1

 +13      ;

 +14      ; See if other COVID-19 Imms need to be added

 +15       SET ORIMM=0

 +16      ;ICR  1990

FOR

               SET ORIMM=$ORDER(^AUTTIMM(ORIMM))

               if 'ORIMM

                   QUIT

               Begin DoDot:1

 +17               SET ORX=$GET(^AUTTIMM(ORIMM,0))

 +18               IF $PIECE(ORX,U,1)'["COVID-19"

                       QUIT

 +19      ;exclude inactive (except Novavax)

                   IF $PIECE(ORX,U,3)'=211

                       IF $PIECE(ORX,U,7)

                           QUIT

 +20      ;already defined

                   IF $DATA(ORIMMS(ORIMM))

                       QUIT

 +21               SET ORINST=ORINST+1

 +22               KILL ORERR

 +23               DO EN^XPAR("SYS","OR IMM REMINDER DIALOG",ORINST,"`"_ORIMM,.ORERR)

 +24               IF +$GET(ORERR)>0

                       DO MES^XPDUTL("  ERROR #"_$PIECE(ORERR,U)_": "_$PIECE(ORERR,U,2))

               End DoDot:1

 +25       DO MES^XPDUTL("  DONE")

 +26       DO BMES^XPDUTL("Setting OR RTN PROCESSED ALERTS value.")

 +27       IF $$GET^XPAR("SYS","OR RTN PROCESSED ALERTS")]""

               DO BMES^XPDUTL("OR RTN PROCESSED ALERTS value is already set")

               QUIT

 +28       KILL ORERR

 +29       DO EN^XPAR("SYS","OR RTN PROCESSED ALERTS",1,"YES",.ORERR)

 +30       IF +$GET(ORERR)>0

               DO MES^XPDUTL("  ERROR #"_$PIECE(ORERR,U)_": "_$PIECE(ORERR,U,2))

 +31       DO MES^XPDUTL("  DONE")

 +32      ;

 +33       QUIT

RI10097   ;;re-index 100.97

 +1        NEW DIK

 +2        DO BMES^XPDUTL("Re-indexing 100.97, 'E' cross-reference...")

 +3        KILL ^OR(100.97,"E")

 +4        SET DIK="^OR(100.97,"

           SET DIK(1)="8^E"

           DO ENALL^DIK

 +5        DO BMES^XPDUTL("Completed re-indexing of 100.97")

 +6        QUIT

ORY405.m