- ORY306 ;ISL/TC,JER - Pre- and Post-install for patch OR*3*306 ;02/15/13 09:34
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**306**;Dec 17, 1997;Build 43
- ;
- PRE ; Initiate pre-init processes
- D UPDTRPT
- S DIK="^DD(101.52,",DA(1)=101.52,DA=23
- D ^DIK
- Q
- ;
- POST ; Initiate post-init processes
- D SETMGS
- D REGRPCS
- ; *** NOTE: Remove DEA Subroutine and Call prior to deployment of I1 ***
- D DEA
- D DLGBULL
- D CONSQO
- D SENDMAIL
- D DELPARAM
- D DELRPC
- D PARAM
- D NOTPARAM
- D QPR^ORY306PR
- D ^ORY306ES
- Q
- ;
- UPDTRPT ; Modify PL Clinical Reports in OE/RR REPORTS file (101.24) to support PL Data Standardization
- N I
- F I=1:1:4 D
- .N DIC,DA,X,J,ORIFN
- .S DIC="^ORD(101.24,",DIC(0)="BIXZ"
- .S X=$S(I=1:"ORRPW PROBLEM ACTIVE",I=2:"ORRPW PROBLEM ALL",I=3:"ORRPW DOD PROBLEM LIST ALL",1:"ORRPW PROBLEM INACTIVE")
- .D ^DIC I Y=-1 K DIC Q ; perform top file level search for record X, if unsuccessful quit
- .S DA(1)=+Y,DIC=DIC_DA(1)_",3,",DIC(0)="LIXZ",ORIFN=DA(1)
- .I ORIFN>1000 D ; if report is a national standard, then proceed to modify the below X fields in the subfile #101.243
- ..F J=1:1:9 D
- ...N X
- ...S X=$S(J=1:"Date of Onset",J=2:"Date Modified",J=3:"Provider Name ",J=4:"Note Narrative",J=5:"[+]",J=6:"Exposures",J=7:"SNOMED CT Description",J=8:"Primary ICD-9-CM Code & Description",J=9:"Secondary ICD-9-CM Code & Description")
- ...I J>6 S DIC("DR")=".02///;.03///;.05///;.06///;.07///;.09///"
- ...D ^DIC I Y=-1 K DIC Q ;perform subfile entry level search for record X, if unsuccessful quit
- ...N DIE,DA,DR,DR1 S DIE=DIC S DA=+Y,DA(1)=ORIFN
- ...I J>6 S DR1=";.02///NO;.05///YES;.06///"_$S(J=7:"18",J=8:"10",J=9:"20")_";.07///NO;.09///FREE TEXT"_$S(J=9:";.04///WORD PROCESSING",1:"")
- ...S DR=".03///"_$S(J=1:"8",J=2:"9",J=3:"10",J=4:"11",J=5:"13",J=6:"12",J=7:"5",J=8:"6",J=9:"7")_$S(J>6:DR1,1:"")
- ...D ^DIE K DIE,DR,DA,Y Q ;edit the SEQUENCE and above DR1 fields of the X COLUMN HEADER multiple accordingly
- ..K DIC Q
- .Q
- Q
- ;
- UNDO ;
- N I
- F I=1:1:3 D
- . N DIC,DA,X,J,ORIFN
- . S DIC="^ORD(101.24,",DIC(0)="BIXZ"
- . S X=$S(I=1:"ORRPW PROBLEM ACTIVE",I=2:"ORRPW PROBLEM ALL",1:"ORRPW PROBLEM INACTIVE")
- . D ^DIC I Y=-1 K DIC Q ; perform top file level search for record X, if unsuccessful quit
- . S DA(1)=+Y,DIC=DIC_DA(1)_",3,",DIC(0)="IXZ",ORIFN=DA(1)
- . I ORIFN>1000 D ; if report is a national standard, then proceed to modify the below X fields in the subfile #101.243
- . . F J=1:1:9 D
- . . . N X S X=$S(J=1:"Date of Onset",J=2:"Date Modified",J=3:"Provider Name ",J=4:"Note Narrative",J=5:"[+]",J=6:"Exposures")
- . . . ;I J>6 S DIC("DR")=".02///;.03///;.05///;.06///;.07///;.09///"
- . . . D ^DIC I Y=-1 K DIC Q ;perform subfile entry level search for record X, if unsuccessful quit
- . . . N DIE,DA,DR,DR1 S DIE=DIC S DA=+Y,DA(1)=ORIFN
- . . . ;I J>6 S DR1=".01///@;.02///@;.05///@;.06///@;.07///@;.09///@"_$S(J=9:";.04///@",1:"")
- . . . S DR=".03///"_$S(J=1:"5",J=2:"6",J=3:"7",J=4:"8",J=5:"10",J=6:"9")
- . . . D ^DIE K DIE,DR,DA,Y Q ;edit the SEQUENCE and above DR1 fields of the X COLUMN HEADER multiple accordingly
- . . K DIC Q
- . Q
- Q
- ;
- SETMGS ; set mail group for OR PROBLEM NTRT BULLETIN
- N ORBIEN,ORBNM,ORERRF,ORFDA,ORGIEN,ORGNM,ORLNE
- N ORMSG,ORTXT
- K ORMSG
- D BMES^XPDUTL("Attaching Mail Groups to OR PROBLEM NTRT BULLETIN")
- S ORBNM="OR PROBLEM NTRT BULLETIN"
- S ORBIEN=$$FIND1^DIC(3.6,"","X",ORBNM,"","","")
- ;If Bulletin not found, error
- I ORBIEN'>0 D I 1
- . S ORMSG(1)="**"
- . S ORMSG(2)="** Bulletin "_ORBNM_" not found"
- . D MES^XPDUTL(.ORMSG) K ORMSG
- . S ORERRF=1
- ELSE D
- . S ORGNM="OR CACS"
- . S ORGIEN=$$FIND1^DIC(3.8,"","X",ORGNM,"","","")
- . ;If Mail Group not found, error
- . I ORGIEN'>0 D Q
- . . S ORMSG(1)="**"
- . . S ORMSG(2)="** Mail Group "_ORGNM_" not found"
- . . D MES^XPDUTL(.ORMSG) K ORMSG
- . . S ORERRF=1
- . ;Attach Mail Group to Bulletin
- . N ORFDA,ORIEN,ORMSG
- . S ORFDA(3.62,"?+2,"_ORBIEN_",",.01)=ORGIEN
- . D UPDATE^DIE("","ORFDA","ORIEN","ORMSG")
- . ;Check for error
- . I $D(ORMSG("DIERR")) D Q
- . . S ORMSG(1)="**"
- . . S ORMSG(2)="** Unable to attach "_ORGNM_" to "_ORBNM
- . . D MES^XPDUTL(.ORMSG) K ORMSG
- . . S ORERRF=1
- . S ORMSG(1)=" "
- . S ORMSG(2)="... G."_ORGNM_$S($G(ORIEN(2,0))="?":" already",1:"")_" attached to "_ORBNM_" Bulletin"
- . D MES^XPDUTL(.ORMSG) K ORMSG
- ;Check for error
- I $G(ORERRF) D
- . S ORMSG(1)="** Post-installation interrupted"
- . S ORMSG(2)="** Please contact Enterprise VistA Support"
- . D MES^XPDUTL(.ORMSG) K ORMSG
- Q
- ;
- INSERT(OPTION,RPC) ; Call FM Updater with each RPC
- ; Input -- OPTION Option file (#19) Name field (#.01)
- ; RPC RPC sub-file (#19.05) RPC field (#.01)
- ; Output -- None
- N FDA,FDAIEN,ERR,DIERR
- S FDA(19,"?1,",.01)=OPTION
- S FDA(19.05,"?+2,?1,",.01)=RPC
- D UPDATE^DIE("E","FDA","FDAIEN","ERR")
- Q
- ;
- REGRPCS ; Register new RPCs
- D INSERT("OR CPRS GUI CHART","ORQQPL PROBLEM NTRT BULLETIN")
- D INSERT("OR CPRS GUI CHART","ORWPCE GET DX TEXT")
- Q
- ;
- SENDDLG(ANAME) ; Return true if the current order dialog should be sent
- I ANAME="GMRCOR CONSULT" Q 1
- I ANAME="GMRCOR REQUEST" Q 1
- Q 0
- ;
- DLGBULL ; send bulletin about modified dialogs <on first install>
- N I,ORD
- F I="GMRCOR CONSULT","GMRCOR REQUEST" S ORD(I)=""
- D EN^ORYDLG(306,.ORD)
- Q
- PARAM ;set param value/WAT
- N ORERR
- D BMES^XPDUTL("Setting paramteter ORCDGMRC EARLIEST DATE DEFAULT to TODAY")
- D EN^XPAR("PKG","ORCDGMRC EARLIEST DATE DEFAULT",1,"TODAY",.ORERR)
- I $D(ORERR) D BMES^XPDUTL("Error setting parameter: "_$P(ORERR,"^",2))
- Q
- ;
- CONSQO ;get GMRC QOs with date default/WAT
- D BMES^XPDUTL("Finding all consult/procedure quick orders with a default value in the EARLIEST")
- D MES^XPDUTL("APPROPRIATE DATE field")
- D BMES^XPDUTL("A MailMan containing the list of quick orders will be sent to the installer")
- D WAIT^DICD
- D GMRCQO
- Q
- GMRCQO ;find GMRC QO's to show the EAD default value/WAT
- K ^TMP("OREAD",$J)
- N GMRCPKG,DA,DA1,QONAME,RESPONSE,OREAD,COUNT
- S GMRCPKG=$O(^DIC(9.4,"B","CONSULT/REQUEST TRACKING",""))
- I +$G(GMRCPKG)'>0 D MES^XPDUTL(" CONSULT/REQUEST TRACKING NOT FOUND IN PACKAGE FILE ") Q
- S OREAD=$O(^ORD(101.41,"B","OR GTX EARLIEST DATE",""))
- I +$G(OREAD)'>0 D MES^XPDUTL(" OR GTX EARLIEST DATE NOT FOUND IN ORDERABLE ITEMS FILE ") Q
- S (QONAME,DA,DA1)="",COUNT=1
- S ^TMP("OREAD",$J,COUNT)="Contains Consult and Procedure quick orders with a default value stored",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="in the Earliest Appropriate Date field.",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="These quick orders should be reviewed in light of the new parameter",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="released in OR*3*306, ORCDGMRC EARLIEST DATE DEFAULT.",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="This parameter sets the default value for the Earliest Appropriate Date.",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="Data format of the entries in this message are as follows:",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="IEN from file 101.41^Quick Order Name^Earliest Appropriate Date value",COUNT=COUNT+1
- S ^TMP("OREAD",$J,COUNT)="",COUNT=COUNT+1
- F S QONAME=$O(^ORD(101.41,"B",QONAME)) Q:QONAME="" D
- .F S DA=$O(^ORD(101.41,"B",QONAME,DA)) Q:DA="" D
- ..Q:$P(^ORD(101.41,DA,0),U,4)'="Q"
- ..Q:$P(^ORD(101.41,DA,0),U,7)'=+GMRCPKG
- ..;now find the EAD in the items for this QO and show that value
- ..F S DA1=$O(^ORD(101.41,DA,6,DA1)) Q:DA1="" D
- ...Q:DA1<1
- ...S RESPONSE=$P(^ORD(101.41,DA,6,DA1,0),U,2)
- ...Q:RESPONSE'=+OREAD
- ...S ^TMP("OREAD",$J,COUNT)=DA_"^"_QONAME_"^"_^ORD(101.41,DA,6,DA1,1),COUNT=COUNT+1
- I COUNT'>9 S ^TMP("OREAD",$J,COUNT)="No Consult or Procedure quick orders found with a default value stored."
- Q
- ;
- SENDMAIL ;SEND MESSAGE W/QOs AND DEFAULT VALUES/WAT
- N XMSUB,XMTEXT,XMY,XMZ,XMDUZ,XMMG,DIFROM
- S XMSUB="CONSULT/PROCEDURE QOs EARLIEST APPROPRIATE DATE DEFAULT VALUE"
- S:$G(DUZ) XMY(DUZ)=""
- S XMDUZ="OR*3.0*306 POST INSTALL"
- S XMTEXT="^TMP(""OREAD"",$J,"
- D ^XMD
- D BMES^XPDUTL("Message #"_$G(XMZ)_" has been sent")
- K ^TMP("OREAD",$J)
- Q
- ;
- DELPARAM ;remove parameter values, then parameter/WAT
- ;;icr 2263 ^XPAR, 10141 XPDUTL
- N ORLIST,ENT,PAR,OERR
- ;get instances of parameter
- S ENT="",PAR="OR USE MH DLL"
- D ENVAL^XPAR(.ORLIST,PAR,1,.OERR)
- ;delete instances
- D BMES^XPDUTL("Attempting to remove values for parameter OR USE MH DLL...")
- F S ENT=$O(ORLIST(ENT)) Q:ENT="" D DEL^XPAR(ENT,PAR,1,.OERR) I $G(OERR)>0 W !,OERR
- D:+$G(OERR)=0 MES^XPDUTL("Delete successful")
- ;delete parameter
- N DA,DIK
- S DIK="^XTV(8989.51,"
- S DA=$O(^XTV(8989.51,"B",PAR,"")) Q:+$G(DA)'>0 D BMES^XPDUTL("Attempting to remove parameter OR USE MH DLL from PARAMETER DEFINITION file")
- D ^DIK D:+$G(DA)>0 MES^XPDUTL("Delete successful")
- Q
- ;
- DELRPC ;remove ORQQPXRM MHDLLDMS/WAT
- ;;icr 10013 ^DIK, 10141 xpdutl
- N DIK,DA
- S DIK="^XWB(8994,"
- S DA=$O(^XWB(8994,"B","ORQQPXRM MHDLLDMS","")) I +$G(DA)'>0 D BMES^XPDUTL("RPC OQQPXRM MHDLLDMS not found. Nothing deleted.") Q
- D BMES^XPDUTL("Attempting to remove ORQQPXRM MHDLLDMS from REMOTE PROCEDURE file")
- D ^DIK
- D:+$G(DA)>0 MES^XPDUTL("Delete successful")
- Q
- ;
- ; *** NOTE: Remove DEA Subroutine and Call prior to deployment of I1 ***
- ;
- DEA ;
- N ORMSG,ORERR
- S ORMSG(1)="By completing the two-factor authentication protocol at this time, you are legally signing the prescription(s) and authorizing the transmission of the above information to the pharmacy for dispersing. "
- S ORMSG(2)="The two-factor authentication protocol may only be completed by the practitioner whose name and DEA registration number appear above."
- D EN^XPAR("SYS","OR DEA TEXT",,.ORMSG,.ORERR)
- Q
- NOTPARAM ; parameter transport routine
- K ^TMP($J,"XPARRSTR")
- N ENT,IDX,ROOT,REF,VAL,I
- S ROOT=$NAME(^TMP($J,"XPARRSTR")),ROOT=$E(ROOT,1,$L(ROOT)-1)_"," ;ICR #2336
- D LOAD
- XX2 S IDX=0,ENT="PKG."_"ORDER ENTRY/RESULTS REPORTING"
- F S IDX=$O(^TMP($J,"XPARRSTR",IDX)) Q:'IDX D
- . N PAR,INST,ORVAL,ORERR K ORVAL
- . S PAR=$P(^TMP($J,"XPARRSTR",IDX,"KEY"),U),INST=$P(^("KEY"),U,2)
- . M ORVAL=^TMP($J,"XPARRSTR",IDX,"VAL")
- . D EN^XPAR(ENT,PAR,INST,.ORVAL,.ORERR) ;ICR #2336
- K ^TMP($J,"XPARRSTR")
- Q
- LOAD ; load data into ^TMP (expects ROOT to be defined)
- S I=1 F S REF=$T(DATA+I) Q:REF="" S VAL=$T(DATA+I+1) D
- . S I=I+2,REF=$P(REF,";",3,999),VAL=$P(VAL,";",3,999)
- . S @(ROOT_REF)=VAL
- Q
- DATA ; parameter data
- ;;7000,"KEY")
- ;;ORB ARCHIVE PERIOD^DEA AUTO DC CS MED ORDER
- ;;7000,"VAL")
- ;;30
- ;;7001,"KEY")
- ;;ORB DELETE MECHANISM^DEA AUTO DC CS MED ORDER
- ;;7001,"VAL")
- ;;Individual Recipient
- ;;7002,"KEY")
- ;;ORB FORWARD BACKUP REVIEWER^DEA AUTO DC CS MED ORDER
- ;;7002,"VAL")
- ;;0
- ;;7003,"KEY")
- ;;ORB FORWARD SUPERVISOR^DEA AUTO DC CS MED ORDER
- ;;7003,"VAL")
- ;;0
- ;;7004,"KEY")
- ;;ORB FORWARD SURROGATES^DEA AUTO DC CS MED ORDER
- ;;7004,"VAL")
- ;;0
- ;;7005,"KEY")
- ;;ORB PROCESSING FLAG^DEA AUTO DC CS MED ORDER
- ;;7005,"VAL")
- ;;Disabled
- ;;7006,"KEY")
- ;;ORB PROVIDER RECIPIENTS^DEA AUTO DC CS MED ORDER
- ;;7006,"VAL")
- ;;OT
- ;;7007,"KEY")
- ;;ORB URGENCY^DEA AUTO DC CS MED ORDER
- ;;7007,"VAL")
- ;;High
- ;;7008,"KEY")
- ;;ORB ARCHIVE PERIOD^DEA CERTIFICATE REVOKED
- ;;7008,"VAL")
- ;;30
- ;;7009,"KEY")
- ;;ORB DELETE MECHANISM^DEA CERTIFICATE REVOKED
- ;;7009,"VAL")
- ;;Individual Recipient
- ;;7010,"KEY")
- ;;ORB FORWARD BACKUP REVIEWER^DEA CERTIFICATE REVOKED
- ;;7010,"VAL")
- ;;0
- ;;7011,"KEY")
- ;;ORB FORWARD SUPERVISOR^DEA CERTIFICATE REVOKED
- ;;7011,"VAL")
- ;;0
- ;;7012,"KEY")
- ;;ORB FORWARD SURROGATES^DEA CERTIFICATE REVOKED
- ;;7012,"VAL")
- ;;0
- ;;7013,"KEY")
- ;;ORB PROCESSING FLAG^DEA CERTIFICATE REVOKED
- ;;7013,"VAL")
- ;;Disabled
- ;;7014,"KEY")
- ;;ORB PROVIDER RECIPIENTS^DEA CERTIFICATE REVOKED
- ;;7014,"VAL")
- ;;OT
- ;;7015,"KEY")
- ;;ORB URGENCY^DEA CERTIFICATE REVOKED
- ;;7015,"VAL")
- ;;High
- ;;7016,"KEY")
- ;;ORB ARCHIVE PERIOD^DEA CERTIFICATE EXPIRED
- ;;7016,"VAL")
- ;;30
- ;;7017,"KEY")
- ;;ORB DELETE MECHANISM^DEA CERTIFICATE EXPIRED
- ;;7017,"VAL")
- ;;Individual Recipient
- ;;7018,"KEY")
- ;;ORB FORWARD BACKUP REVIEWER^DEA CERTIFICATE EXPIRED
- ;;7018,"VAL")
- ;;0
- ;;7019,"KEY")
- ;;ORB FORWARD SUPERVISOR^DEA CERTIFICATE EXPIRED
- ;;7019,"VAL")
- ;;0
- ;;7020,"KEY")
- ;;ORB FORWARD SURROGATES^DEA CERTIFICATE EXPIRED
- ;;7020,"VAL")
- ;;0
- ;;7021,"KEY")
- ;;ORB PROCESSING FLAG^DEA CERTIFICATE EXPIRED
- ;;7021,"VAL")
- ;;Disabled
- ;;7022,"KEY")
- ;;ORB PROVIDER RECIPIENTS^DEA CERTIFICATE EXPIRED
- ;;7022,"VAL")
- ;;O
- ;;7023,"KEY")
- ;;ORB URGENCY^DEA CERTIFICATE EXPIRED
- ;;7023,"VAL")
- ;;High
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY306 12653 printed Feb 19, 2025@00:07:23 Page 2
- ORY306 ;ISL/TC,JER - Pre- and Post-install for patch OR*3*306 ;02/15/13 09:34
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**306**;Dec 17, 1997;Build 43
- +2 ;
- PRE ; Initiate pre-init processes
- +1 DO UPDTRPT
- +2 SET DIK="^DD(101.52,"
- SET DA(1)=101.52
- SET DA=23
- +3 DO ^DIK
- +4 QUIT
- +5 ;
- POST ; Initiate post-init processes
- +1 DO SETMGS
- +2 DO REGRPCS
- +3 ; *** NOTE: Remove DEA Subroutine and Call prior to deployment of I1 ***
- +4 DO DEA
- +5 DO DLGBULL
- +6 DO CONSQO
- +7 DO SENDMAIL
- +8 DO DELPARAM
- +9 DO DELRPC
- +10 DO PARAM
- +11 DO NOTPARAM
- +12 DO QPR^ORY306PR
- +13 DO ^ORY306ES
- +14 QUIT
- +15 ;
- UPDTRPT ; Modify PL Clinical Reports in OE/RR REPORTS file (101.24) to support PL Data Standardization
- +1 NEW I
- +2 FOR I=1:1:4
- Begin DoDot:1
- +3 NEW DIC,DA,X,J,ORIFN
- +4 SET DIC="^ORD(101.24,"
- SET DIC(0)="BIXZ"
- +5 SET X=$SELECT(I=1:"ORRPW PROBLEM ACTIVE",I=2:"ORRPW PROBLEM ALL",I=3:"ORRPW DOD PROBLEM LIST ALL",1:"ORRPW PROBLEM INACTIVE")
- +6 ; perform top file level search for record X, if unsuccessful quit
- DO ^DIC
- IF Y=-1
- KILL DIC
- QUIT
- +7 SET DA(1)=+Y
- SET DIC=DIC_DA(1)_",3,"
- SET DIC(0)="LIXZ"
- SET ORIFN=DA(1)
- +8 ; if report is a national standard, then proceed to modify the below X fields in the subfile #101.243
- IF ORIFN>1000
- Begin DoDot:2
- +9 FOR J=1:1:9
- Begin DoDot:3
- +10 NEW X
- +11 SET X=$SELECT(J=1:"Date of Onset",J=2:"Date Modified",J=3:"Provider Name ",J=4:"Note Narrative",J=5:"[+]",J=6:"Exposures",J=7:"SNOMED CT Description",J=8:"Primary ICD-9-CM Code & Description",J=9:"Secondary ICD-9-CM C
- ode & Description")
- +12 IF J>6
- SET DIC("DR")=".02///;.03///;.05///;.06///;.07///;.09///"
- +13 ;perform subfile entry level search for record X, if unsuccessful quit
- DO ^DIC
- IF Y=-1
- KILL DIC
- QUIT
- +14 NEW DIE,DA,DR,DR1
- SET DIE=DIC
- SET DA=+Y
- SET DA(1)=ORIFN
- +15 IF J>6
- SET DR1=";.02///NO;.05///YES;.06///"_$SELECT(J=7:"18",J=8:"10",J=9:"20")_";.07///NO;.09///FREE TEXT"_$SELECT(J=9:";.04///WORD PROCESSING",1:"")
- +16 SET DR=".03///"_$SELECT(J=1:"8",J=2:"9",J=3:"10",J=4:"11",J=5:"13",J=6:"12",J=7:"5",J=8:"6",J=9:"7")_$SELECT(J>6:DR1,1:"")
- +17 ;edit the SEQUENCE and above DR1 fields of the X COLUMN HEADER multiple accordingly
- DO ^DIE
- KILL DIE,DR,DA,Y
- QUIT
- End DoDot:3
- +18 KILL DIC
- QUIT
- End DoDot:2
- +19 QUIT
- End DoDot:1
- +20 QUIT
- +21 ;
- UNDO ;
- +1 NEW I
- +2 FOR I=1:1:3
- Begin DoDot:1
- +3 NEW DIC,DA,X,J,ORIFN
- +4 SET DIC="^ORD(101.24,"
- SET DIC(0)="BIXZ"
- +5 SET X=$SELECT(I=1:"ORRPW PROBLEM ACTIVE",I=2:"ORRPW PROBLEM ALL",1:"ORRPW PROBLEM INACTIVE")
- +6 ; perform top file level search for record X, if unsuccessful quit
- DO ^DIC
- IF Y=-1
- KILL DIC
- QUIT
- +7 SET DA(1)=+Y
- SET DIC=DIC_DA(1)_",3,"
- SET DIC(0)="IXZ"
- SET ORIFN=DA(1)
- +8 ; if report is a national standard, then proceed to modify the below X fields in the subfile #101.243
- IF ORIFN>1000
- Begin DoDot:2
- +9 FOR J=1:1:9
- Begin DoDot:3
- +10 NEW X
- SET X=$SELECT(J=1:"Date of Onset",J=2:"Date Modified",J=3:"Provider Name ",J=4:"Note Narrative",J=5:"[+]",J=6:"Exposures")
- +11 ;I J>6 S DIC("DR")=".02///;.03///;.05///;.06///;.07///;.09///"
- +12 ;perform subfile entry level search for record X, if unsuccessful quit
- DO ^DIC
- IF Y=-1
- KILL DIC
- QUIT
- +13 NEW DIE,DA,DR,DR1
- SET DIE=DIC
- SET DA=+Y
- SET DA(1)=ORIFN
- +14 ;I J>6 S DR1=".01///@;.02///@;.05///@;.06///@;.07///@;.09///@"_$S(J=9:";.04///@",1:"")
- +15 SET DR=".03///"_$SELECT(J=1:"5",J=2:"6",J=3:"7",J=4:"8",J=5:"10",J=6:"9")
- +16 ;edit the SEQUENCE and above DR1 fields of the X COLUMN HEADER multiple accordingly
- DO ^DIE
- KILL DIE,DR,DA,Y
- QUIT
- End DoDot:3
- +17 KILL DIC
- QUIT
- End DoDot:2
- +18 QUIT
- End DoDot:1
- +19 QUIT
- +20 ;
- SETMGS ; set mail group for OR PROBLEM NTRT BULLETIN
- +1 NEW ORBIEN,ORBNM,ORERRF,ORFDA,ORGIEN,ORGNM,ORLNE
- +2 NEW ORMSG,ORTXT
- +3 KILL ORMSG
- +4 DO BMES^XPDUTL("Attaching Mail Groups to OR PROBLEM NTRT BULLETIN")
- +5 SET ORBNM="OR PROBLEM NTRT BULLETIN"
- +6 SET ORBIEN=$$FIND1^DIC(3.6,"","X",ORBNM,"","","")
- +7 ;If Bulletin not found, error
- +8 IF ORBIEN'>0
- Begin DoDot:1
- +9 SET ORMSG(1)="**"
- +10 SET ORMSG(2)="** Bulletin "_ORBNM_" not found"
- +11 DO MES^XPDUTL(.ORMSG)
- KILL ORMSG
- +12 SET ORERRF=1
- End DoDot:1
- IF 1
- +13 IF '$TEST
- Begin DoDot:1
- +14 SET ORGNM="OR CACS"
- +15 SET ORGIEN=$$FIND1^DIC(3.8,"","X",ORGNM,"","","")
- +16 ;If Mail Group not found, error
- +17 IF ORGIEN'>0
- Begin DoDot:2
- +18 SET ORMSG(1)="**"
- +19 SET ORMSG(2)="** Mail Group "_ORGNM_" not found"
- +20 DO MES^XPDUTL(.ORMSG)
- KILL ORMSG
- +21 SET ORERRF=1
- End DoDot:2
- QUIT
- +22 ;Attach Mail Group to Bulletin
- +23 NEW ORFDA,ORIEN,ORMSG
- +24 SET ORFDA(3.62,"?+2,"_ORBIEN_",",.01)=ORGIEN
- +25 DO UPDATE^DIE("","ORFDA","ORIEN","ORMSG")
- +26 ;Check for error
- +27 IF $DATA(ORMSG("DIERR"))
- Begin DoDot:2
- +28 SET ORMSG(1)="**"
- +29 SET ORMSG(2)="** Unable to attach "_ORGNM_" to "_ORBNM
- +30 DO MES^XPDUTL(.ORMSG)
- KILL ORMSG
- +31 SET ORERRF=1
- End DoDot:2
- QUIT
- +32 SET ORMSG(1)=" "
- +33 SET ORMSG(2)="... G."_ORGNM_$SELECT($GET(ORIEN(2,0))="?":" already",1:"")_" attached to "_ORBNM_" Bulletin"
- +34 DO MES^XPDUTL(.ORMSG)
- KILL ORMSG
- End DoDot:1
- +35 ;Check for error
- +36 IF $GET(ORERRF)
- Begin DoDot:1
- +37 SET ORMSG(1)="** Post-installation interrupted"
- +38 SET ORMSG(2)="** Please contact Enterprise VistA Support"
- +39 DO MES^XPDUTL(.ORMSG)
- KILL ORMSG
- End DoDot:1
- +40 QUIT
- +41 ;
- INSERT(OPTION,RPC) ; Call FM Updater with each RPC
- +1 ; Input -- OPTION Option file (#19) Name field (#.01)
- +2 ; RPC RPC sub-file (#19.05) RPC field (#.01)
- +3 ; Output -- None
- +4 NEW FDA,FDAIEN,ERR,DIERR
- +5 SET FDA(19,"?1,",.01)=OPTION
- +6 SET FDA(19.05,"?+2,?1,",.01)=RPC
- +7 DO UPDATE^DIE("E","FDA","FDAIEN","ERR")
- +8 QUIT
- +9 ;
- REGRPCS ; Register new RPCs
- +1 DO INSERT("OR CPRS GUI CHART","ORQQPL PROBLEM NTRT BULLETIN")
- +2 DO INSERT("OR CPRS GUI CHART","ORWPCE GET DX TEXT")
- +3 QUIT
- +4 ;
- SENDDLG(ANAME) ; Return true if the current order dialog should be sent
- +1 IF ANAME="GMRCOR CONSULT"
- QUIT 1
- +2 IF ANAME="GMRCOR REQUEST"
- QUIT 1
- +3 QUIT 0
- +4 ;
- DLGBULL ; send bulletin about modified dialogs <on first install>
- +1 NEW I,ORD
- +2 FOR I="GMRCOR CONSULT","GMRCOR REQUEST"
- SET ORD(I)=""
- +3 DO EN^ORYDLG(306,.ORD)
- +4 QUIT
- PARAM ;set param value/WAT
- +1 NEW ORERR
- +2 DO BMES^XPDUTL("Setting paramteter ORCDGMRC EARLIEST DATE DEFAULT to TODAY")
- +3 DO EN^XPAR("PKG","ORCDGMRC EARLIEST DATE DEFAULT",1,"TODAY",.ORERR)
- +4 IF $DATA(ORERR)
- DO BMES^XPDUTL("Error setting parameter: "_$PIECE(ORERR,"^",2))
- +5 QUIT
- +6 ;
- CONSQO ;get GMRC QOs with date default/WAT
- +1 DO BMES^XPDUTL("Finding all consult/procedure quick orders with a default value in the EARLIEST")
- +2 DO MES^XPDUTL("APPROPRIATE DATE field")
- +3 DO BMES^XPDUTL("A MailMan containing the list of quick orders will be sent to the installer")
- +4 DO WAIT^DICD
- +5 DO GMRCQO
- +6 QUIT
- GMRCQO ;find GMRC QO's to show the EAD default value/WAT
- +1 KILL ^TMP("OREAD",$JOB)
- +2 NEW GMRCPKG,DA,DA1,QONAME,RESPONSE,OREAD,COUNT
- +3 SET GMRCPKG=$ORDER(^DIC(9.4,"B","CONSULT/REQUEST TRACKING",""))
- +4 IF +$GET(GMRCPKG)'>0
- DO MES^XPDUTL(" CONSULT/REQUEST TRACKING NOT FOUND IN PACKAGE FILE ")
- QUIT
- +5 SET OREAD=$ORDER(^ORD(101.41,"B","OR GTX EARLIEST DATE",""))
- +6 IF +$GET(OREAD)'>0
- DO MES^XPDUTL(" OR GTX EARLIEST DATE NOT FOUND IN ORDERABLE ITEMS FILE ")
- QUIT
- +7 SET (QONAME,DA,DA1)=""
- SET COUNT=1
- +8 SET ^TMP("OREAD",$JOB,COUNT)="Contains Consult and Procedure quick orders with a default value stored"
- SET COUNT=COUNT+1
- +9 SET ^TMP("OREAD",$JOB,COUNT)="in the Earliest Appropriate Date field."
- SET COUNT=COUNT+1
- +10 SET ^TMP("OREAD",$JOB,COUNT)="These quick orders should be reviewed in light of the new parameter"
- SET COUNT=COUNT+1
- +11 SET ^TMP("OREAD",$JOB,COUNT)="released in OR*3*306, ORCDGMRC EARLIEST DATE DEFAULT."
- SET COUNT=COUNT+1
- +12 SET ^TMP("OREAD",$JOB,COUNT)="This parameter sets the default value for the Earliest Appropriate Date."
- SET COUNT=COUNT+1
- +13 SET ^TMP("OREAD",$JOB,COUNT)=""
- SET COUNT=COUNT+1
- +14 SET ^TMP("OREAD",$JOB,COUNT)="Data format of the entries in this message are as follows:"
- SET COUNT=COUNT+1
- +15 SET ^TMP("OREAD",$JOB,COUNT)="IEN from file 101.41^Quick Order Name^Earliest Appropriate Date value"
- SET COUNT=COUNT+1
- +16 SET ^TMP("OREAD",$JOB,COUNT)=""
- SET COUNT=COUNT+1
- +17 FOR
- SET QONAME=$ORDER(^ORD(101.41,"B",QONAME))
- if QONAME=""
- QUIT
- Begin DoDot:1
- +18 FOR
- SET DA=$ORDER(^ORD(101.41,"B",QONAME,DA))
- if DA=""
- QUIT
- Begin DoDot:2
- +19 if $PIECE(^ORD(101.41,DA,0),U,4)'="Q"
- QUIT
- +20 if $PIECE(^ORD(101.41,DA,0),U,7)'=+GMRCPKG
- QUIT
- +21 ;now find the EAD in the items for this QO and show that value
- +22 FOR
- SET DA1=$ORDER(^ORD(101.41,DA,6,DA1))
- if DA1=""
- QUIT
- Begin DoDot:3
- +23 if DA1<1
- QUIT
- +24 SET RESPONSE=$PIECE(^ORD(101.41,DA,6,DA1,0),U,2)
- +25 if RESPONSE'=+OREAD
- QUIT
- +26 SET ^TMP("OREAD",$JOB,COUNT)=DA_"^"_QONAME_"^"_^ORD(101.41,DA,6,DA1,1)
- SET COUNT=COUNT+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 IF COUNT'>9
- SET ^TMP("OREAD",$JOB,COUNT)="No Consult or Procedure quick orders found with a default value stored."
- +28 QUIT
- +29 ;
- SENDMAIL ;SEND MESSAGE W/QOs AND DEFAULT VALUES/WAT
- +1 NEW XMSUB,XMTEXT,XMY,XMZ,XMDUZ,XMMG,DIFROM
- +2 SET XMSUB="CONSULT/PROCEDURE QOs EARLIEST APPROPRIATE DATE DEFAULT VALUE"
- +3 if $GET(DUZ)
- SET XMY(DUZ)=""
- +4 SET XMDUZ="OR*3.0*306 POST INSTALL"
- +5 SET XMTEXT="^TMP(""OREAD"",$J,"
- +6 DO ^XMD
- +7 DO BMES^XPDUTL("Message #"_$GET(XMZ)_" has been sent")
- +8 KILL ^TMP("OREAD",$JOB)
- +9 QUIT
- +10 ;
- DELPARAM ;remove parameter values, then parameter/WAT
- +1 ;;icr 2263 ^XPAR, 10141 XPDUTL
- +2 NEW ORLIST,ENT,PAR,OERR
- +3 ;get instances of parameter
- +4 SET ENT=""
- SET PAR="OR USE MH DLL"
- +5 DO ENVAL^XPAR(.ORLIST,PAR,1,.OERR)
- +6 ;delete instances
- +7 DO BMES^XPDUTL("Attempting to remove values for parameter OR USE MH DLL...")
- +8 FOR
- SET ENT=$ORDER(ORLIST(ENT))
- if ENT=""
- QUIT
- DO DEL^XPAR(ENT,PAR,1,.OERR)
- IF $GET(OERR)>0
- WRITE !,OERR
- +9 if +$GET(OERR)=0
- DO MES^XPDUTL("Delete successful")
- +10 ;delete parameter
- +11 NEW DA,DIK
- +12 SET DIK="^XTV(8989.51,"
- +13 SET DA=$ORDER(^XTV(8989.51,"B",PAR,""))
- if +$GET(DA)'>0
- QUIT
- DO BMES^XPDUTL("Attempting to remove parameter OR USE MH DLL from PARAMETER DEFINITION file")
- +14 DO ^DIK
- if +$GET(DA)>0
- DO MES^XPDUTL("Delete successful")
- +15 QUIT
- +16 ;
- DELRPC ;remove ORQQPXRM MHDLLDMS/WAT
- +1 ;;icr 10013 ^DIK, 10141 xpdutl
- +2 NEW DIK,DA
- +3 SET DIK="^XWB(8994,"
- +4 SET DA=$ORDER(^XWB(8994,"B","ORQQPXRM MHDLLDMS",""))
- IF +$GET(DA)'>0
- DO BMES^XPDUTL("RPC OQQPXRM MHDLLDMS not found. Nothing deleted.")
- QUIT
- +5 DO BMES^XPDUTL("Attempting to remove ORQQPXRM MHDLLDMS from REMOTE PROCEDURE file")
- +6 DO ^DIK
- +7 if +$GET(DA)>0
- DO MES^XPDUTL("Delete successful")
- +8 QUIT
- +9 ;
- +10 ; *** NOTE: Remove DEA Subroutine and Call prior to deployment of I1 ***
- +11 ;
- DEA ;
- +1 NEW ORMSG,ORERR
- +2 SET ORMSG(1)="By completing the two-factor authentication protocol at this time, you are legally signing the prescription(s) and authorizing the transmission of the above information to the pharmacy for dispersing. "
- +3 SET ORMSG(2)="The two-factor authentication protocol may only be completed by the practitioner whose name and DEA registration number appear above."
- +4 DO EN^XPAR("SYS","OR DEA TEXT",,.ORMSG,.ORERR)
- +5 QUIT
- NOTPARAM ; parameter transport routine
- +1 KILL ^TMP($JOB,"XPARRSTR")
- +2 NEW ENT,IDX,ROOT,REF,VAL,I
- +3 ;ICR #2336
- SET ROOT=$NAME(^TMP($JOB,"XPARRSTR"))
- SET ROOT=$EXTRACT(ROOT,1,$LENGTH(ROOT)-1)_","
- +4 DO LOAD
- XX2 SET IDX=0
- SET ENT="PKG."_"ORDER ENTRY/RESULTS REPORTING"
- +1 FOR
- SET IDX=$ORDER(^TMP($JOB,"XPARRSTR",IDX))
- if 'IDX
- QUIT
- Begin DoDot:1
- +2 NEW PAR,INST,ORVAL,ORERR
- KILL ORVAL
- +3 SET PAR=$PIECE(^TMP($JOB,"XPARRSTR",IDX,"KEY"),U)
- SET INST=$PIECE(^("KEY"),U,2)
- +4 MERGE ORVAL=^TMP($JOB,"XPARRSTR",IDX,"VAL")
- +5 ;ICR #2336
- DO EN^XPAR(ENT,PAR,INST,.ORVAL,.ORERR)
- End DoDot:1
- +6 KILL ^TMP($JOB,"XPARRSTR")
- +7 QUIT
- LOAD ; load data into ^TMP (expects ROOT to be defined)
- +1 SET I=1
- FOR
- SET REF=$TEXT(DATA+I)
- if REF=""
- QUIT
- SET VAL=$TEXT(DATA+I+1)
- Begin DoDot:1
- +2 SET I=I+2
- SET REF=$PIECE(REF,";",3,999)
- SET VAL=$PIECE(VAL,";",3,999)
- +3 SET @(ROOT_REF)=VAL
- End DoDot:1
- +4 QUIT
- DATA ; parameter data
- +1 ;;7000,"KEY")
- +2 ;;ORB ARCHIVE PERIOD^DEA AUTO DC CS MED ORDER
- +3 ;;7000,"VAL")
- +4 ;;30
- +5 ;;7001,"KEY")
- +6 ;;ORB DELETE MECHANISM^DEA AUTO DC CS MED ORDER
- +7 ;;7001,"VAL")
- +8 ;;Individual Recipient
- +9 ;;7002,"KEY")
- +10 ;;ORB FORWARD BACKUP REVIEWER^DEA AUTO DC CS MED ORDER
- +11 ;;7002,"VAL")
- +12 ;;0
- +13 ;;7003,"KEY")
- +14 ;;ORB FORWARD SUPERVISOR^DEA AUTO DC CS MED ORDER
- +15 ;;7003,"VAL")
- +16 ;;0
- +17 ;;7004,"KEY")
- +18 ;;ORB FORWARD SURROGATES^DEA AUTO DC CS MED ORDER
- +19 ;;7004,"VAL")
- +20 ;;0
- +21 ;;7005,"KEY")
- +22 ;;ORB PROCESSING FLAG^DEA AUTO DC CS MED ORDER
- +23 ;;7005,"VAL")
- +24 ;;Disabled
- +25 ;;7006,"KEY")
- +26 ;;ORB PROVIDER RECIPIENTS^DEA AUTO DC CS MED ORDER
- +27 ;;7006,"VAL")
- +28 ;;OT
- +29 ;;7007,"KEY")
- +30 ;;ORB URGENCY^DEA AUTO DC CS MED ORDER
- +31 ;;7007,"VAL")
- +32 ;;High
- +33 ;;7008,"KEY")
- +34 ;;ORB ARCHIVE PERIOD^DEA CERTIFICATE REVOKED
- +35 ;;7008,"VAL")
- +36 ;;30
- +37 ;;7009,"KEY")
- +38 ;;ORB DELETE MECHANISM^DEA CERTIFICATE REVOKED
- +39 ;;7009,"VAL")
- +40 ;;Individual Recipient
- +41 ;;7010,"KEY")
- +42 ;;ORB FORWARD BACKUP REVIEWER^DEA CERTIFICATE REVOKED
- +43 ;;7010,"VAL")
- +44 ;;0
- +45 ;;7011,"KEY")
- +46 ;;ORB FORWARD SUPERVISOR^DEA CERTIFICATE REVOKED
- +47 ;;7011,"VAL")
- +48 ;;0
- +49 ;;7012,"KEY")
- +50 ;;ORB FORWARD SURROGATES^DEA CERTIFICATE REVOKED
- +51 ;;7012,"VAL")
- +52 ;;0
- +53 ;;7013,"KEY")
- +54 ;;ORB PROCESSING FLAG^DEA CERTIFICATE REVOKED
- +55 ;;7013,"VAL")
- +56 ;;Disabled
- +57 ;;7014,"KEY")
- +58 ;;ORB PROVIDER RECIPIENTS^DEA CERTIFICATE REVOKED
- +59 ;;7014,"VAL")
- +60 ;;OT
- +61 ;;7015,"KEY")
- +62 ;;ORB URGENCY^DEA CERTIFICATE REVOKED
- +63 ;;7015,"VAL")
- +64 ;;High
- +65 ;;7016,"KEY")
- +66 ;;ORB ARCHIVE PERIOD^DEA CERTIFICATE EXPIRED
- +67 ;;7016,"VAL")
- +68 ;;30
- +69 ;;7017,"KEY")
- +70 ;;ORB DELETE MECHANISM^DEA CERTIFICATE EXPIRED
- +71 ;;7017,"VAL")
- +72 ;;Individual Recipient
- +73 ;;7018,"KEY")
- +74 ;;ORB FORWARD BACKUP REVIEWER^DEA CERTIFICATE EXPIRED
- +75 ;;7018,"VAL")
- +76 ;;0
- +77 ;;7019,"KEY")
- +78 ;;ORB FORWARD SUPERVISOR^DEA CERTIFICATE EXPIRED
- +79 ;;7019,"VAL")
- +80 ;;0
- +81 ;;7020,"KEY")
- +82 ;;ORB FORWARD SURROGATES^DEA CERTIFICATE EXPIRED
- +83 ;;7020,"VAL")
- +84 ;;0
- +85 ;;7021,"KEY")
- +86 ;;ORB PROCESSING FLAG^DEA CERTIFICATE EXPIRED
- +87 ;;7021,"VAL")
- +88 ;;Disabled
- +89 ;;7022,"KEY")
- +90 ;;ORB PROVIDER RECIPIENTS^DEA CERTIFICATE EXPIRED
- +91 ;;7022,"VAL")
- +92 ;;O
- +93 ;;7023,"KEY")
- +94 ;;ORB URGENCY^DEA CERTIFICATE EXPIRED
- +95 ;;7023,"VAL")
- +96 ;;High