MAGIP138 ;WOIFO/PMK,NST,MAT - Install code for MAG*3.0*138 (DIX) ; 31 Jul 2013 12:20 PM
;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 2013
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
; There are no environment checks here but the MAGIP138 has to be
; referenced by the "Environment Check Routine" field of the KIDS
; build so that entry points of the routine are available to the
; KIDS during all installation phases.
Q
;
;+++++ INSTALLATION ERROR HANDLING
ERROR ;
S:$D(XPDNM) XPDABORT=1
;--- Display the messages and store them to the INSTALL file
D DUMP^MAGUERR1(),ABTMSG^MAGKIDS()
Q
;
;***** PRE-INSTALL CODE
PRE ;
N DA,DIK
D CONVERT1
;--- P130
; Image Never Existed Status added to field 113 in 2005
S DIK="^DD(2006.1,",DA=113,DA(1)=2005 D ^DIK
; Image Never Existed Status added to field 113 in 2005.1
S DIK="^DD(2006.1,",DA=113,DA(1)=2005.1 D ^DIK
Q
;
;***** POST-INSTALL CODE
POS ;
N CALLBACK,MENU
D CLEAR^MAGUERR(1)
;
;=== RPC REGISTRATION ===
;
;--- P79 Link new remote procedures to context option MAG DICOM VISA.
S CALLBACK="$$ADDRPCS^"_$NA(MAGKIDS1("RPCL079^"_$T(+0),"MAG DICOM VISA"))
I $$CP^MAGKIDS("MAG ATTACH RPCS P79",CALLBACK)<0 D ERROR Q
;
;--- P110 Link new remote procedures to the Broker context option.
S CALLBACK="$$ADDRPCS^"_$NA(MAGKIDS1("RPCL110^"_$T(+0),"MAG WINDOWS"))
I $$CP^MAGKIDS("MAG ATTACH RPCS P110 WIN",CALLBACK)<0 D ERROR Q
;
;--- P130 Link new remote procedures to context option MAG WINDOWS.
S CALLBACK="$$ADDRPCS^"_$NA(MAGKIDS1("RPCL130^"_$T(+0),"MAG WINDOWS"))
I $$CP^MAGKIDS("MAG ATTACH RPCS P130",CALLBACK)<0 D ERROR Q
;
;--- P136 Link new remote procedures to context option MAG DICOM VISA.
S CALLBACK="$$ADDRPCS^"_$NA(MAGKIDS1("RPCL136V^"_$T(+0),"MAG DICOM VISA"))
I $$CP^MAGKIDS("MAG ATTACH RPCS P136",CALLBACK)<0 D ERROR Q
;
;--- P137 Link new remote procedures to context option MAG DICOM VISA.
S CALLBACK="$$ADDRPCS^"_$NA(MAGKIDS1("RPCL137V^"_$T(+0),"MAG DICOM VISA"))
I $$CP^MAGKIDS("MAG ATTACH RPCS P137",CALLBACK)<0 D ERROR Q
;
;--- P138 Link new remote procedures to context option MAGTP WORKLIST MGR.
S CALLBACK="$$ADDRPCS^"_$NA(MAGKIDS1("RPCL138V^"_$T(+0),"MAGTP WORKLIST MGR"))
I $$CP^MAGKIDS("MAG ATTACH RPCS P138",CALLBACK)<0 D ERROR Q
;
;=== Various Updates ===
;
;--- P79 Add WORKLIST entry.
S CALLBACK="$$ADDWRKLS^MAGI138O()"
I $$CP^MAGKIDS("MAG ADD WORKLIST ENTRY",CALLBACK)<0 D ERROR Q
;
;--- P79 Add MAG WORK ITEM STATUS entries.
S CALLBACK="$$ADDSTATS^MAGI138O()"
I $$CP^MAGKIDS("MAG ADD WORK ITEM STATUS",CALLBACK)<0 D ERROR Q
;
;--- P79 Add StorageCommit entry to the MAG WORK ITEM SUBTYPE file.
S CALLBACK="$$ADDSUBTP^MAGI138O()"
I $$CP^MAGKIDS("MAG ADD WORK ITEM SUBTYPE",CALLBACK)<0 D ERROR Q
;
;--- P110 Update Driver
I $$CP^MAGKIDS("MAG P110 UPDATE","$$UPD110^"_$T(+0))<0 D ERROR Q
;
;--- P130 Various Updates
I $$CP^MAGKIDS("MAG P130 UPDATE","$$UPD130^MAGI138O()")<0 D ERROR Q
;
;--- P138TP Various Updates
I $$CP^MAGKIDS("MAG TP UPDATE","$$UPD138^MAGI138O()")<0 D ERROR Q ;UPD138
;
;--- Menu addition
; Edit CLINICAL SPECIALTY DICOM & HL7 file
S MENU=$$ADD^XPDMENU("MAGD DICOM MENU","MAGD EDIT CLIN SPEC DICOM/HL7","ECS",99)
I MENU'=1 D MES^MAGKIDS("MAGD DICOM MENU option MAGD EDIT CLIN SPEC DICOM/HL7 not installed: "_MENU)
;
; Print DICOM Object Output File Status
S MENU=$$ADD^XPDMENU("MAGD DICOM MENU","MAGD PRINT DICOM OBJECT EXPORT","EXP",99)
I MENU'=1 D MES^MAGKIDS("MAGD DICOM MENU option MAGD PRINT DICOM OBJECT EXPORT not installed: "_MENU)
;
D DELRTNS^MAGI138O
; Delete MAGI138O
D
. N X,DEL
. S X="MAGI138O"
. S DEL=^%ZOSF("DEL")
. X DEL
. D MES^MAGKIDS(""""_X_""" routine has been deleted.")
. Q
;--- Send the notification e-mail
D BMES^XPDUTL("Post Install Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
Q
;
;+++++ Various updates
UPD110() ;
;
D CONVERT2
D NEW7792
D NEW7794
D ENTRYACT("MAGD RECEIVE EVENTS","D ^MAGDHOWC") ; CPRS Consult Request Tracking
D ENTRYACT("MAGD APPOINTMENT","D ^MAGDHOWS") ; SDAM Scheduling/Appointment Management
D ADTSUBS
D MAILUPDT
Q 0
;
MAILUPDT ; Add the mail group and subject for MAGDHOW* processing errors
D BMES^XPDUTL("Add CPRS DICOM & HL7 Mail Message group to the Mail Group file: "_$$FMTE^XLFDT($$NOW^XLFDT))
D ADDMG ; Add CPRS DICOM & HL7 Mail Message group to the Mail Group file (XMB(3.8)
D BMES^XPDUTL("Add Message Subject for Mail Management to Site Parameters - with interval: "_$$FMTE^XLFDT($$NOW^XLFDT))
D ADDMS(0) ; Add Message Subject for Mail Management to Site Parameters - with interval
D BMES^XPDUTL("Add CPRS DICOM & HL7 Mail groups to BP Message subfile: "_$$FMTE^XLFDT($$NOW^XLFDT))
D DLKP ; Add CPRS DICOM & HL7 Mail groups to BP Message subfile
Q
;
CONVERT1 ; convert file 2006.5831 to the new global format - don't build indices
N CLINCNT,CLINIC,CLINIEN,CPTIEN,DIK,HL7SUBLIST,IPROCIDX,ISPECIDX
N LOCATION,NEWIEN,OLDIEN,PROCEDURE,SERVICE,X,Y
;
I $G(^MAG(2006.5831,0))?1"CLINICAL SPECIALTY DICOM & HL7".E D Q
. D MES^MAGKIDS("Conversion to the new format has already been performed.")
. Q
;
L +^MAG(2006.5831):1E9
;
D MES^MAGKIDS("Converting DICOM HEALTHCARE PROVIDER SERVICE file (#2006.5831) to new format.")
;
K ^TMP("MAG",$J,"P110")
;
S (NEWIEN,OLDIEN)=0
F S OLDIEN=$O(^MAG(2006.5831,OLDIEN)) Q:'OLDIEN D
. S NEWIEN=NEWIEN+1
. S X=^MAG(2006.5831,OLDIEN,0)
. S SERVICE=$P(X,"^",1),ISPECIDX=$P(X,"^",2),LOCATION=$P(X,"^",3)
. S (PROCEDURE,IPROCIDX,HL7SUBLIST,CPTIEN)=""
. S Y=SERVICE_"^"_PROCEDURE_"^"_ISPECIDX_"^"_IPROCIDX_"^"_LOCATION_"^"_CPTIEN_"^"_HL7SUBLIST
. S ^TMP("MAG",$J,"P110",NEWIEN,0)=Y
. S (CLINCNT,CLINIEN)=0 F S CLINIEN=$O(^MAG(2006.5831,SERVICE,1,CLINIEN)) Q:'CLINIEN D
. . S CLINCNT=CLINCNT+1,CLINIC=^MAG(2006.5831,SERVICE,1,CLINIEN,0)
. . S ^TMP("MAG",$J,"P110",NEWIEN,1,CLINCNT,0)=CLINIC
. . Q
. I CLINCNT S ^TMP("MAG",$J,"P110",NEWIEN,1,0)="^2006.58311^"_CLINCNT_"^"_CLINCNT
. Q
S ^TMP("MAG",$J,"P110",0)="CLINICAL SPECIALTY DICOM & HL7^2006.5831P^"_NEWIEN_"^"_NEWIEN
S DIK="^MAG(2006.5831,"
D ENALL2^DIK ; Delete all cross-reference
L -^MAG(2006.5831)
;
; Delete DICOM HEALTHCARE PROVIDER SERVICE file (#2006.5831)
D DELFILE^MAGKIDS(2006.5831,"DE","")
Q
;
CONVERT2 ; restore the new file 2006.5831 and build cross-references
N DIK
;
I $G(^MAG(2006.5831,0))?1"CLINICAL SPECIALTY DICOM & HL7".E,$P(^(0),"^",4) D Q
. D MES^MAGKIDS("Conversion to the new format has already been performed.")
. Q
;
; Update file #2006.5831 security here because of the FileMan bug
N SECURITY
S SECURITY("AUDIT")="@"
S SECURITY("DD")="@"
S SECURITY("DEL")="@"
S SECURITY("LAYGO")="@"
S SECURITY("RD")="@"
S SECURITY("WR")="@"
D FILESEC^DDMOD(2006.5831,.SECURITY) ; supported ICR #2916
;
L +^MAG(2006.5831):1E9
K ^MAG(2006.5831)
M ^MAG(2006.5831)=^TMP("MAG",$J,"P110")
K ^TMP("MAG",$J,"P110")
S DIK="^MAG(2006.5831," D IXALL^DIK ; create all the cross-references
D MES^MAGKIDS("Conversion to CLINICAL SPECIALTY DICOM & HL7 file (#2006.5831) complete.")
L -^MAG(2006.5831)
Q
;
NEW7792 ; create the MAGD SENDER entry in the HLO APPLICATION REGISTRY (file 779.2)
N DESCRIPTION,DIC,DIERR,I,IENS,MAGERR,MAGFDA,MAGIENS,NAME,PACKAGE,OWNER,X,Y
;
S NAME="MAGD SENDER"
;
; check to see if <NAME> already exists
S DIC=779.2,DIC(0)="BX",X=NAME D ^DIC
I Y>0 D Q
. D MES^MAGKIDS(""""_NAME_""" already exists in the HLO APPLICATION REGISTRY.")
. Q
;
; get package file number for IMAGING
S DIC=9.4,DIC(0)="BX",X="IMAGING" D ^DIC
I Y=-1 D Q
. D MES^MAGKIDS("""IMAGING"" does not exist in the PACKAGE file (#9.4).")
. Q
S PACKAGE=+Y
;
S IENS="+1,"
S MAGFDA(779.2,IENS,.01)=NAME ; APPLICATION NAME
S MAGFDA(779.2,IENS,2)=PACKAGE ; PACKAGE FILE LINK
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) D Q
. D MES^MAGKIDS("Error in creating """_NAME_""" in the HLO APPLICATION REGISTRY.")
. F I=1:1 Q:'$D(MAGERR("DIERR",1,"TEXT",I)) D
. . D MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
. . Q
. Q
Q
;
NEW7794 ; create the entries in the HLO SUBSCRIPTION REGISTRY (file 779.4)
N DESCRIPTION,NAME,OWNER
;
; create the MAGD ADT entry
S NAME="MAGD ADT"
S DESCRIPTION="ADT subscription list for clinical specialty systems"
S OWNER="MAGD (ADT)"
D NEW7794A(NAME,DESCRIPTION,OWNER)
;
; create the MAGD DEFAULT entry
S NAME="MAGD DEFAULT"
S DESCRIPTION="Default subscription list for CPRS consults & procedures"
S OWNER="MAGD (Imaging Default)"
D NEW7794A(NAME,DESCRIPTION,OWNER)
;
Q
;
NEW7794A(NAME,DESCRIPTION,OWNER) ; create the entry in file 779.4
N DIC,DIERR,I,IENS,MAGERR,MAGFDA,MAGIENS,X,Y
;
; check to see if <NAME> already exists
S DIC=779.4,DIC(0)="BX",X=NAME D ^DIC
I Y>0 D Q
. D MES^MAGKIDS(""""_NAME_""" already exists in the HLO SUBSCRIPTION REGISTRY.")
. Q
;
S IENS="+1,"
S MAGFDA(779.4,IENS,.01)=NAME ; NAME
S MAGFDA(779.4,IENS,.02)=OWNER ; OWNER
S MAGFDA(779.4,IENS,.03)=DESCRIPTION ; DESCRIPTION
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) D Q
. D MES^MAGKIDS("Error in creating """_NAME_""" in the HLO SUBSCRIPTION REGISTRY.")
. F I=1:1 Q:'$D(MAGERR("DIERR",1,"TEXT",I)) D
. . D MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
. . Q
. Q
Q
;
ENTRYACT(PROTOCOL,ACTION) ; update the protocol's ENTRY ACTION
N DIC,IENS,MAGERR,MAGFDA,MAGIENS,X,Y
S DIC=101,DIC(0)="BX",X=PROTOCOL D ^DIC
I Y=-1 D Q
. D MES^MAGKIDS("Error in updating protocol "_X_" - it is not defined.")
. Q
S IENS=+Y_","
S MAGFDA(101,IENS,20)=ACTION ; ENTRY ACTION
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) D Q
. D MES^MAGKIDS("Error in updating protocol "_X_".")
. F I=1:1 Q:'$D(MAGERR("DIERR",1,"TEXT",I)) D
. . D MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
. . Q
. Q
Q
;
ADTSUBS ; add new subscribers to MAG CPACS A01 - A13 ADT event drives
;
D ADTSUBS1("A01","inpatient admission")
D ADTSUBS1("A02","patient transfer")
D ADTSUBS1("A03","patient discharge")
D ADTSUBS1("A11","admission cancellation")
D ADTSUBS1("A12","transfer cancellation")
D ADTSUBS1("A13","discharge cancellation")
;
Q
;
ADTSUBS1(EVENT,TYPE) ; add one subscriber
N DESCRIPTION,EVENTDRIVER,EVENTDRIVERIEN,ITEMTEXT,SUBSCRIBER,SUBSCRIBERIEN
N DIC,IENS,MAGERR,MAGFDA,MAGIENS,X,Y
;
S EVENTDRIVER="MAG CPACS "_EVENT,SUBSCRIBER=EVENTDRIVER_" SUBS-HLO"
S ITEMTEXT="Routes "_TYPE_"s using HLO"
S DESCRIPTION(1)="This protocol routes "_TYPE_" messages"
S DESCRIPTION(2)="a commercial PACS using the HL7 Optimized package."
;
;
; first, find the event driver protocol - it must exist
S DIC=101,DIC(0)="BX",X=EVENTDRIVER D ^DIC
I Y=-1 D Q
. D MES^MAGKIDS("Error in updating protocol "_X_" - it is not defined.")
. Q
S EVENTDRIVERIEN=+Y
;
;
; second, find the HLO subscriber protocol - it shouldn't exist
S DIC=101,DIC(0)="BX",X=SUBSCRIBER D ^DIC
I Y'=-1 D Q
. D MES^MAGKIDS("Note: Updating protocol "_X_" - it is already defined.")
. Q
;
;
; third, create the HLO subscriber protocol
S IENS="+1,"
S MAGFDA(101,IENS,.01)=SUBSCRIBER ; NAME
S MAGFDA(101,IENS,1)=ITEMTEXT ; ITEM TEXT
S MAGFDA(101,IENS,3.5)="DESCRIPTION" ; DESCRIPTION (wp field)
S MAGFDA(101,IENS,4)="S" ; TYPE (subscriber)
S MAGFDA(101,IENS,5)=DUZ ; CREATOR
S MAGFDA(101,IENS,99)=$H ; TIMESTAMP
S MAGFDA(101,IENS,770.2)="MAGD-CLIENT" ; RECEIVING APPLICATION <------------------------
S MAGFDA(101,IENS,770.3)="ADT" ; TRANSACTION MESSAGE TYPE
S MAGFDA(101,IENS,770.4)=EVENT ; EVENT TYPE
S MAGFDA(101,IENS,770.11)="ACK" ; RESPONSE MESSAGE TYPE
S MAGFDA(101,IENS,771)="D ENTRY^MAGDHOWA" ; PROCESSING ROUTINE
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) D Q
. D MES^MAGKIDS("Error in updating subscriber protocol "_X_".")
. F I=1:1 Q:'$D(MAGERR("DIERR",1,"TEXT",I)) D
. . D MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
. . Q
. Q
S SUBSCRIBERIEN=MAGIENS(1)
;
; fourth, add the new HLO subscriber to the event driver protocol
S IENS="+2,"_EVENTDRIVERIEN_","
S MAGFDA(101.0775,IENS,.01)=SUBSCRIBERIEN
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) D Q
. D MES^MAGKIDS("Error in updating event driver protocol "_X_".")
. F I=1:1 Q:'$D(MAGERR("DIERR",1,"TEXT",I)) D
. . D MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
. . Q
. Q
Q
;
; code to handle adding a mail message for MAGDHOW* errors
;
ADDMS(INTERVAL) ; Add Message Subjects for Mail Management
N I,J,K,MAGFDA,MSG,IEN,MAGERR
S IEN=0
F S IEN=$O(^MAG(2006.1,IEN)) Q:'IEN D
. F J=1:1:1 S K=$P($T(TEXT+J),";",3) D
. . Q:$D(^MAG(2006.1,IEN,6,"B",K)) ; Do not re-configure
. . S MAGFDA(2006.166,"?+1,"_IEN_",",.01)=K
. . S MAGFDA(2006.166,"?+1,"_IEN_",",1)=INTERVAL
. . D UPDATE^DIE("","MAGFDA","","MAGERR")
. . I $D(DIERR) D BMES^XPDUTL("Error updating the BP Mail Message Subfile: "_MAGERR("DIERR",1,"TEXT",1)) K DIERR,MAGERR
. . Q
. Q
Q
ADDMG ; Add Mail Message groups to the Mail Group file (XMB(3.8))
N PL,NMSP
S PL=0
F S PL=$O(^MAG(2006.1,PL)) Q:'PL D
. S NMSP=$P($G(^MAG(2006.1,PL,0)),U,2)
. Q:NMSP=""
. D ADD(NMSP)
. D ADDDUZ(NMSP)
. Q
Q
ADD(NMSP) ;
N J,K,L,MAGFDA,MSG,IEN,MAGIEN,MAGERR
F J=1:1:1 S K=$P($T(TEXT+J),";",3) D
. I '$D(^XMB(3.8,"B","MAG_"_NMSP_"_"_$E($$TRIM^MAGQBUT4(K),1,20))) D
. . S L=$O(^XMB(3.8,"B","MAG_"_NMSP_"_"_$E($$TRIM^MAGQBUT4(K),1,20),""))
. . S MAGFDA(3.8,"?+"_J_",",.01)="MAG_"_NMSP_"_"_$E($$TRIM^MAGQBUT4(K),1,20)
. . D UPDATE^DIE("","MAGFDA","MAGIEN","MAGERR")
. . I $D(DIERR) D BMES^XPDUTL("Error Adding Imaging Mail Groups: "_MAGERR("DIERR",1,"TEXT",1)) K DIERR,MAGERR,MAGFDA Q
. . K MAGFDA,DIERR,MAGERR
. . S MAGFDA(3.8,MAGIEN(J)_",",4)="PU"
. . D FILE^DIE("I","MAGFDA","MAGERR")
. . K DIERR,MAGERR,MAGFDA,MAGIEN
. . Q
. Q
Q
;
ADDDUZ(NMSP) ;
N J,K,L,MAGFDA,MSG,IEN,MAGIEN,MAGERR
F J=1:1:1 S K=$P($T(TEXT+J),";",3) D
. S L=$O(^XMB(3.8,"B","MAG_"_NMSP_"_"_$E($$TRIM^MAGQBUT4(K),1,20),""))
. S MAGFDA(3.81,"?+1,"_L_",",.01)=DUZ
. D UPDATE^DIE("","MAGFDA","MAGIEN","MAGERR")
. I $D(DIERR) D BMES^XPDUTL("Error Adding Imaging Mail Group member: "_MAGERR("DIERR",1,"TEXT",1))
. K DIERR,MAGERR,MAGFDA,MAGIEN
Q
;
DLKP ; Add Generic Mail groups to BP Message subfile
N PL,I,J,MAGFDA,MSGROOT,MG,DIERR,MAGIEN,MAGERR,NMSP
S PL=0
F S PL=$O(^MAG(2006.1,PL)) Q:'PL D
. S I=0,NMSP=$P($G(^MAG(2006.1,PL,0)),U,2)
. Q:NMSP=""
. F S I=$O(^MAG(2006.1,PL,6,I)) Q:'I D
. . S MG=$P($G(^MAG(2006.1,PL,6,I,0)),"^",1)
. . S J=$$FIND1^DIC(3.8,"","","MAG_"_NMSP_"_"_$E($$TRIM^MAGQBUT4(MG),1,20),"","","MSGROOT")
. . Q:$D(^MAG(2006.1,PL,6,I,1,"B",J)) ; Do not re-configure
. . I J D
. . . S MAGFDA(2006.1662,"+1,"_I_","_PL_",",.01)=J
. . . D UPDATE^DIE("","MAGFDA","MAGIEN","MAGERR")
. . . I $D(DIERR) D BMES^XPDUTL("Error Adding Generic Mail Groups: "_MAGERR("DIERR",1,"TEXT",1)) K DIERR,MAGERR
. . . Q
. . Q
. Q
K MAGFDA,MSGROOT,MAGIEN,MSGROOT
Q
TEXT ; Message Subjects
;;CPRS_DICOM_and_HL7
Q
;+++++ LIST OF NEW REMOTE PROCEDURES
; have a list in format ;;MAG4 IMAGE LIST
RPCL110 ;
;;MAG3 TELEREADER CPT CODELOOKUP
Q
RPCL130 ;
;;MAG GET DICOM QUEUE LIST
;;MAG SEND IMAGE
;;MAGV CREATE WORK ITEM
;;MAGV GET WORK ITEM
;;MAGV GET NEXT WORK ITEM
;;MAGV FIND WORK ITEM
;;MAGV UPDATE WORK ITEM
;;MAGV ADD WORK ITEM TAGS
;;MAGV DELETE WORK ITEM
Q
;
RPCL079 ;
;;MAG DICOM CHECK AE TITLE
;;MAG DICOM GET AE ENTRY
;;MAG DICOM GET AE ENTRY LOC
;;MAGVC WI DELETE
;;MAGVC WI GET
;;MAGVC WI LIST
;;MAGVC WI SUBMIT NEW
;;MAGVC WI UPDATE STATUS
Q
;
RPCL136V ;
;;MAGV GET RAD DX CODES
;;MAGV GET RAD IMAGING LOCATIONS
;;MAGV GET RAD STD RPTS
;;MAGV GENERATE DICOM UID
Q
;
RPCL137V ;
;;MAGV GET IRRADIATION DOSE
;;MAGV ATTACH IRRADIATION DOSE
Q
;
RPCL138V ;
;;MAGTP GET ACTIVE
;;MAGTP GET CASES
;;MAGTP GET CPRS REPORT
;;MAGTP GET NOTE
;;MAGTP GET PREFERENCES
;;MAGTP GET RETENTION DAYS
;;MAGTP GET SLIDES
;;MAGTP GET USER
;;MAGTP PUT NOTE
;;MAGTP PUT PREFERENCES
;;MAGTP RESERVE CASE
;;MAGTP SET RETENTION DAYS
;;MAGTP USER
;;MAGG GET TIMEOUT
;;MAGG INSTALL
;;MAGG PAT INFO
;;MAGG VERIFY ESIG
;;MAGGUPREFGET
;;MAGGUPREFSAVE
;;MAGGUSERKEYS
;;MAG BROKER SECURITY
;;VAFCTFU CONVERT DFN TO ICN
;;VAFCTFU CONVERT ICN TO DFN
;;DG SENSITIVE RECORD ACCESS
;;DG SENSITIVE RECORD BULLETIN
;;XWB CREATE CONTEXT
;;MAG3 SET TIMEOUT
;;MAGGHSLIST
;;MAGGHS
Q
;
; MAGIP138
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGIP138 17818 printed Dec 13, 2024@02:04:05 Page 2
MAGIP138 ;WOIFO/PMK,NST,MAT - Install code for MAG*3.0*138 (DIX) ; 31 Jul 2013 12:20 PM
+1 ;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 2013
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ; There are no environment checks here but the MAGIP138 has to be
+18 ; referenced by the "Environment Check Routine" field of the KIDS
+19 ; build so that entry points of the routine are available to the
+20 ; KIDS during all installation phases.
+21 QUIT
+22 ;
+23 ;+++++ INSTALLATION ERROR HANDLING
ERROR ;
+1 if $DATA(XPDNM)
SET XPDABORT=1
+2 ;--- Display the messages and store them to the INSTALL file
+3 DO DUMP^MAGUERR1()
DO ABTMSG^MAGKIDS()
+4 QUIT
+5 ;
+6 ;***** PRE-INSTALL CODE
PRE ;
+1 NEW DA,DIK
+2 DO CONVERT1
+3 ;--- P130
+4 ; Image Never Existed Status added to field 113 in 2005
+5 SET DIK="^DD(2006.1,"
SET DA=113
SET DA(1)=2005
DO ^DIK
+6 ; Image Never Existed Status added to field 113 in 2005.1
+7 SET DIK="^DD(2006.1,"
SET DA=113
SET DA(1)=2005.1
DO ^DIK
+8 QUIT
+9 ;
+10 ;***** POST-INSTALL CODE
POS ;
+1 NEW CALLBACK,MENU
+2 DO CLEAR^MAGUERR(1)
+3 ;
+4 ;=== RPC REGISTRATION ===
+5 ;
+6 ;--- P79 Link new remote procedures to context option MAG DICOM VISA.
+7 SET CALLBACK="$$ADDRPCS^"_$NAME(MAGKIDS1("RPCL079^"_$TEXT(+0),"MAG DICOM VISA"))
+8 IF $$CP^MAGKIDS("MAG ATTACH RPCS P79",CALLBACK)<0
DO ERROR
QUIT
+9 ;
+10 ;--- P110 Link new remote procedures to the Broker context option.
+11 SET CALLBACK="$$ADDRPCS^"_$NAME(MAGKIDS1("RPCL110^"_$TEXT(+0),"MAG WINDOWS"))
+12 IF $$CP^MAGKIDS("MAG ATTACH RPCS P110 WIN",CALLBACK)<0
DO ERROR
QUIT
+13 ;
+14 ;--- P130 Link new remote procedures to context option MAG WINDOWS.
+15 SET CALLBACK="$$ADDRPCS^"_$NAME(MAGKIDS1("RPCL130^"_$TEXT(+0),"MAG WINDOWS"))
+16 IF $$CP^MAGKIDS("MAG ATTACH RPCS P130",CALLBACK)<0
DO ERROR
QUIT
+17 ;
+18 ;--- P136 Link new remote procedures to context option MAG DICOM VISA.
+19 SET CALLBACK="$$ADDRPCS^"_$NAME(MAGKIDS1("RPCL136V^"_$TEXT(+0),"MAG DICOM VISA"))
+20 IF $$CP^MAGKIDS("MAG ATTACH RPCS P136",CALLBACK)<0
DO ERROR
QUIT
+21 ;
+22 ;--- P137 Link new remote procedures to context option MAG DICOM VISA.
+23 SET CALLBACK="$$ADDRPCS^"_$NAME(MAGKIDS1("RPCL137V^"_$TEXT(+0),"MAG DICOM VISA"))
+24 IF $$CP^MAGKIDS("MAG ATTACH RPCS P137",CALLBACK)<0
DO ERROR
QUIT
+25 ;
+26 ;--- P138 Link new remote procedures to context option MAGTP WORKLIST MGR.
+27 SET CALLBACK="$$ADDRPCS^"_$NAME(MAGKIDS1("RPCL138V^"_$TEXT(+0),"MAGTP WORKLIST MGR"))
+28 IF $$CP^MAGKIDS("MAG ATTACH RPCS P138",CALLBACK)<0
DO ERROR
QUIT
+29 ;
+30 ;=== Various Updates ===
+31 ;
+32 ;--- P79 Add WORKLIST entry.
+33 SET CALLBACK="$$ADDWRKLS^MAGI138O()"
+34 IF $$CP^MAGKIDS("MAG ADD WORKLIST ENTRY",CALLBACK)<0
DO ERROR
QUIT
+35 ;
+36 ;--- P79 Add MAG WORK ITEM STATUS entries.
+37 SET CALLBACK="$$ADDSTATS^MAGI138O()"
+38 IF $$CP^MAGKIDS("MAG ADD WORK ITEM STATUS",CALLBACK)<0
DO ERROR
QUIT
+39 ;
+40 ;--- P79 Add StorageCommit entry to the MAG WORK ITEM SUBTYPE file.
+41 SET CALLBACK="$$ADDSUBTP^MAGI138O()"
+42 IF $$CP^MAGKIDS("MAG ADD WORK ITEM SUBTYPE",CALLBACK)<0
DO ERROR
QUIT
+43 ;
+44 ;--- P110 Update Driver
+45 IF $$CP^MAGKIDS("MAG P110 UPDATE","$$UPD110^"_$TEXT(+0))<0
DO ERROR
QUIT
+46 ;
+47 ;--- P130 Various Updates
+48 IF $$CP^MAGKIDS("MAG P130 UPDATE","$$UPD130^MAGI138O()")<0
DO ERROR
QUIT
+49 ;
+50 ;--- P138TP Various Updates
+51 ;UPD138
IF $$CP^MAGKIDS("MAG TP UPDATE","$$UPD138^MAGI138O()")<0
DO ERROR
QUIT
+52 ;
+53 ;--- Menu addition
+54 ; Edit CLINICAL SPECIALTY DICOM & HL7 file
+55 SET MENU=$$ADD^XPDMENU("MAGD DICOM MENU","MAGD EDIT CLIN SPEC DICOM/HL7","ECS",99)
+56 IF MENU'=1
DO MES^MAGKIDS("MAGD DICOM MENU option MAGD EDIT CLIN SPEC DICOM/HL7 not installed: "_MENU)
+57 ;
+58 ; Print DICOM Object Output File Status
+59 SET MENU=$$ADD^XPDMENU("MAGD DICOM MENU","MAGD PRINT DICOM OBJECT EXPORT","EXP",99)
+60 IF MENU'=1
DO MES^MAGKIDS("MAGD DICOM MENU option MAGD PRINT DICOM OBJECT EXPORT not installed: "_MENU)
+61 ;
+62 DO DELRTNS^MAGI138O
+63 ; Delete MAGI138O
+64 Begin DoDot:1
+65 NEW X,DEL
+66 SET X="MAGI138O"
+67 SET DEL=^%ZOSF("DEL")
+68 XECUTE DEL
+69 DO MES^MAGKIDS(""""_X_""" routine has been deleted.")
+70 QUIT
End DoDot:1
+71 ;--- Send the notification e-mail
+72 DO BMES^XPDUTL("Post Install Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
+73 DO INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
+74 QUIT
+75 ;
+76 ;+++++ Various updates
UPD110() ;
+1 ;
+2 DO CONVERT2
+3 DO NEW7792
+4 DO NEW7794
+5 ; CPRS Consult Request Tracking
DO ENTRYACT("MAGD RECEIVE EVENTS","D ^MAGDHOWC")
+6 ; SDAM Scheduling/Appointment Management
DO ENTRYACT("MAGD APPOINTMENT","D ^MAGDHOWS")
+7 DO ADTSUBS
+8 DO MAILUPDT
+9 QUIT 0
+10 ;
MAILUPDT ; Add the mail group and subject for MAGDHOW* processing errors
+1 DO BMES^XPDUTL("Add CPRS DICOM & HL7 Mail Message group to the Mail Group file: "_$$FMTE^XLFDT($$NOW^XLFDT))
+2 ; Add CPRS DICOM & HL7 Mail Message group to the Mail Group file (XMB(3.8)
DO ADDMG
+3 DO BMES^XPDUTL("Add Message Subject for Mail Management to Site Parameters - with interval: "_$$FMTE^XLFDT($$NOW^XLFDT))
+4 ; Add Message Subject for Mail Management to Site Parameters - with interval
DO ADDMS(0)
+5 DO BMES^XPDUTL("Add CPRS DICOM & HL7 Mail groups to BP Message subfile: "_$$FMTE^XLFDT($$NOW^XLFDT))
+6 ; Add CPRS DICOM & HL7 Mail groups to BP Message subfile
DO DLKP
+7 QUIT
+8 ;
CONVERT1 ; convert file 2006.5831 to the new global format - don't build indices
+1 NEW CLINCNT,CLINIC,CLINIEN,CPTIEN,DIK,HL7SUBLIST,IPROCIDX,ISPECIDX
+2 NEW LOCATION,NEWIEN,OLDIEN,PROCEDURE,SERVICE,X,Y
+3 ;
+4 IF $GET(^MAG(2006.5831,0))?1"CLINICAL SPECIALTY DICOM & HL7".E
Begin DoDot:1
+5 DO MES^MAGKIDS("Conversion to the new format has already been performed.")
+6 QUIT
End DoDot:1
QUIT
+7 ;
+8 LOCK +^MAG(2006.5831):1E9
+9 ;
+10 DO MES^MAGKIDS("Converting DICOM HEALTHCARE PROVIDER SERVICE file (#2006.5831) to new format.")
+11 ;
+12 KILL ^TMP("MAG",$JOB,"P110")
+13 ;
+14 SET (NEWIEN,OLDIEN)=0
+15 FOR
SET OLDIEN=$ORDER(^MAG(2006.5831,OLDIEN))
if 'OLDIEN
QUIT
Begin DoDot:1
+16 SET NEWIEN=NEWIEN+1
+17 SET X=^MAG(2006.5831,OLDIEN,0)
+18 SET SERVICE=$PIECE(X,"^",1)
SET ISPECIDX=$PIECE(X,"^",2)
SET LOCATION=$PIECE(X,"^",3)
+19 SET (PROCEDURE,IPROCIDX,HL7SUBLIST,CPTIEN)=""
+20 SET Y=SERVICE_"^"_PROCEDURE_"^"_ISPECIDX_"^"_IPROCIDX_"^"_LOCATION_"^"_CPTIEN_"^"_HL7SUBLIST
+21 SET ^TMP("MAG",$JOB,"P110",NEWIEN,0)=Y
+22 SET (CLINCNT,CLINIEN)=0
FOR
SET CLINIEN=$ORDER(^MAG(2006.5831,SERVICE,1,CLINIEN))
if 'CLINIEN
QUIT
Begin DoDot:2
+23 SET CLINCNT=CLINCNT+1
SET CLINIC=^MAG(2006.5831,SERVICE,1,CLINIEN,0)
+24 SET ^TMP("MAG",$JOB,"P110",NEWIEN,1,CLINCNT,0)=CLINIC
+25 QUIT
End DoDot:2
+26 IF CLINCNT
SET ^TMP("MAG",$JOB,"P110",NEWIEN,1,0)="^2006.58311^"_CLINCNT_"^"_CLINCNT
+27 QUIT
End DoDot:1
+28 SET ^TMP("MAG",$JOB,"P110",0)="CLINICAL SPECIALTY DICOM & HL7^2006.5831P^"_NEWIEN_"^"_NEWIEN
+29 SET DIK="^MAG(2006.5831,"
+30 ; Delete all cross-reference
DO ENALL2^DIK
+31 LOCK -^MAG(2006.5831)
+32 ;
+33 ; Delete DICOM HEALTHCARE PROVIDER SERVICE file (#2006.5831)
+34 DO DELFILE^MAGKIDS(2006.5831,"DE","")
+35 QUIT
+36 ;
CONVERT2 ; restore the new file 2006.5831 and build cross-references
+1 NEW DIK
+2 ;
+3 IF $GET(^MAG(2006.5831,0))?1"CLINICAL SPECIALTY DICOM & HL7".E
IF $PIECE(^(0),"^",4)
Begin DoDot:1
+4 DO MES^MAGKIDS("Conversion to the new format has already been performed.")
+5 QUIT
End DoDot:1
QUIT
+6 ;
+7 ; Update file #2006.5831 security here because of the FileMan bug
+8 NEW SECURITY
+9 SET SECURITY("AUDIT")="@"
+10 SET SECURITY("DD")="@"
+11 SET SECURITY("DEL")="@"
+12 SET SECURITY("LAYGO")="@"
+13 SET SECURITY("RD")="@"
+14 SET SECURITY("WR")="@"
+15 ; supported ICR #2916
DO FILESEC^DDMOD(2006.5831,.SECURITY)
+16 ;
+17 LOCK +^MAG(2006.5831):1E9
+18 KILL ^MAG(2006.5831)
+19 MERGE ^MAG(2006.5831)=^TMP("MAG",$JOB,"P110")
+20 KILL ^TMP("MAG",$JOB,"P110")
+21 ; create all the cross-references
SET DIK="^MAG(2006.5831,"
DO IXALL^DIK
+22 DO MES^MAGKIDS("Conversion to CLINICAL SPECIALTY DICOM & HL7 file (#2006.5831) complete.")
+23 LOCK -^MAG(2006.5831)
+24 QUIT
+25 ;
NEW7792 ; create the MAGD SENDER entry in the HLO APPLICATION REGISTRY (file 779.2)
+1 NEW DESCRIPTION,DIC,DIERR,I,IENS,MAGERR,MAGFDA,MAGIENS,NAME,PACKAGE,OWNER,X,Y
+2 ;
+3 SET NAME="MAGD SENDER"
+4 ;
+5 ; check to see if <NAME> already exists
+6 SET DIC=779.2
SET DIC(0)="BX"
SET X=NAME
DO ^DIC
+7 IF Y>0
Begin DoDot:1
+8 DO MES^MAGKIDS(""""_NAME_""" already exists in the HLO APPLICATION REGISTRY.")
+9 QUIT
End DoDot:1
QUIT
+10 ;
+11 ; get package file number for IMAGING
+12 SET DIC=9.4
SET DIC(0)="BX"
SET X="IMAGING"
DO ^DIC
+13 IF Y=-1
Begin DoDot:1
+14 DO MES^MAGKIDS("""IMAGING"" does not exist in the PACKAGE file (#9.4).")
+15 QUIT
End DoDot:1
QUIT
+16 SET PACKAGE=+Y
+17 ;
+18 SET IENS="+1,"
+19 ; APPLICATION NAME
SET MAGFDA(779.2,IENS,.01)=NAME
+20 ; PACKAGE FILE LINK
SET MAGFDA(779.2,IENS,2)=PACKAGE
+21 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+22 IF $DATA(DIERR)
Begin DoDot:1
+23 DO MES^MAGKIDS("Error in creating """_NAME_""" in the HLO APPLICATION REGISTRY.")
+24 FOR I=1:1
if '$DATA(MAGERR("DIERR",1,"TEXT",I))
QUIT
Begin DoDot:2
+25 DO MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
QUIT
+28 QUIT
+29 ;
NEW7794 ; create the entries in the HLO SUBSCRIPTION REGISTRY (file 779.4)
+1 NEW DESCRIPTION,NAME,OWNER
+2 ;
+3 ; create the MAGD ADT entry
+4 SET NAME="MAGD ADT"
+5 SET DESCRIPTION="ADT subscription list for clinical specialty systems"
+6 SET OWNER="MAGD (ADT)"
+7 DO NEW7794A(NAME,DESCRIPTION,OWNER)
+8 ;
+9 ; create the MAGD DEFAULT entry
+10 SET NAME="MAGD DEFAULT"
+11 SET DESCRIPTION="Default subscription list for CPRS consults & procedures"
+12 SET OWNER="MAGD (Imaging Default)"
+13 DO NEW7794A(NAME,DESCRIPTION,OWNER)
+14 ;
+15 QUIT
+16 ;
NEW7794A(NAME,DESCRIPTION,OWNER) ; create the entry in file 779.4
+1 NEW DIC,DIERR,I,IENS,MAGERR,MAGFDA,MAGIENS,X,Y
+2 ;
+3 ; check to see if <NAME> already exists
+4 SET DIC=779.4
SET DIC(0)="BX"
SET X=NAME
DO ^DIC
+5 IF Y>0
Begin DoDot:1
+6 DO MES^MAGKIDS(""""_NAME_""" already exists in the HLO SUBSCRIPTION REGISTRY.")
+7 QUIT
End DoDot:1
QUIT
+8 ;
+9 SET IENS="+1,"
+10 ; NAME
SET MAGFDA(779.4,IENS,.01)=NAME
+11 ; OWNER
SET MAGFDA(779.4,IENS,.02)=OWNER
+12 ; DESCRIPTION
SET MAGFDA(779.4,IENS,.03)=DESCRIPTION
+13 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+14 IF $DATA(DIERR)
Begin DoDot:1
+15 DO MES^MAGKIDS("Error in creating """_NAME_""" in the HLO SUBSCRIPTION REGISTRY.")
+16 FOR I=1:1
if '$DATA(MAGERR("DIERR",1,"TEXT",I))
QUIT
Begin DoDot:2
+17 DO MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
QUIT
+20 QUIT
+21 ;
ENTRYACT(PROTOCOL,ACTION) ; update the protocol's ENTRY ACTION
+1 NEW DIC,IENS,MAGERR,MAGFDA,MAGIENS,X,Y
+2 SET DIC=101
SET DIC(0)="BX"
SET X=PROTOCOL
DO ^DIC
+3 IF Y=-1
Begin DoDot:1
+4 DO MES^MAGKIDS("Error in updating protocol "_X_" - it is not defined.")
+5 QUIT
End DoDot:1
QUIT
+6 SET IENS=+Y_","
+7 ; ENTRY ACTION
SET MAGFDA(101,IENS,20)=ACTION
+8 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+9 IF $DATA(DIERR)
Begin DoDot:1
+10 DO MES^MAGKIDS("Error in updating protocol "_X_".")
+11 FOR I=1:1
if '$DATA(MAGERR("DIERR",1,"TEXT",I))
QUIT
Begin DoDot:2
+12 DO MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
QUIT
+15 QUIT
+16 ;
ADTSUBS ; add new subscribers to MAG CPACS A01 - A13 ADT event drives
+1 ;
+2 DO ADTSUBS1("A01","inpatient admission")
+3 DO ADTSUBS1("A02","patient transfer")
+4 DO ADTSUBS1("A03","patient discharge")
+5 DO ADTSUBS1("A11","admission cancellation")
+6 DO ADTSUBS1("A12","transfer cancellation")
+7 DO ADTSUBS1("A13","discharge cancellation")
+8 ;
+9 QUIT
+10 ;
ADTSUBS1(EVENT,TYPE) ; add one subscriber
+1 NEW DESCRIPTION,EVENTDRIVER,EVENTDRIVERIEN,ITEMTEXT,SUBSCRIBER,SUBSCRIBERIEN
+2 NEW DIC,IENS,MAGERR,MAGFDA,MAGIENS,X,Y
+3 ;
+4 SET EVENTDRIVER="MAG CPACS "_EVENT
SET SUBSCRIBER=EVENTDRIVER_" SUBS-HLO"
+5 SET ITEMTEXT="Routes "_TYPE_"s using HLO"
+6 SET DESCRIPTION(1)="This protocol routes "_TYPE_" messages"
+7 SET DESCRIPTION(2)="a commercial PACS using the HL7 Optimized package."
+8 ;
+9 ;
+10 ; first, find the event driver protocol - it must exist
+11 SET DIC=101
SET DIC(0)="BX"
SET X=EVENTDRIVER
DO ^DIC
+12 IF Y=-1
Begin DoDot:1
+13 DO MES^MAGKIDS("Error in updating protocol "_X_" - it is not defined.")
+14 QUIT
End DoDot:1
QUIT
+15 SET EVENTDRIVERIEN=+Y
+16 ;
+17 ;
+18 ; second, find the HLO subscriber protocol - it shouldn't exist
+19 SET DIC=101
SET DIC(0)="BX"
SET X=SUBSCRIBER
DO ^DIC
+20 IF Y'=-1
Begin DoDot:1
+21 DO MES^MAGKIDS("Note: Updating protocol "_X_" - it is already defined.")
+22 QUIT
End DoDot:1
QUIT
+23 ;
+24 ;
+25 ; third, create the HLO subscriber protocol
+26 SET IENS="+1,"
+27 ; NAME
SET MAGFDA(101,IENS,.01)=SUBSCRIBER
+28 ; ITEM TEXT
SET MAGFDA(101,IENS,1)=ITEMTEXT
+29 ; DESCRIPTION (wp field)
SET MAGFDA(101,IENS,3.5)="DESCRIPTION"
+30 ; TYPE (subscriber)
SET MAGFDA(101,IENS,4)="S"
+31 ; CREATOR
SET MAGFDA(101,IENS,5)=DUZ
+32 ; TIMESTAMP
SET MAGFDA(101,IENS,99)=$HOROLOG
+33 ; RECEIVING APPLICATION <------------------------
SET MAGFDA(101,IENS,770.2)="MAGD-CLIENT"
+34 ; TRANSACTION MESSAGE TYPE
SET MAGFDA(101,IENS,770.3)="ADT"
+35 ; EVENT TYPE
SET MAGFDA(101,IENS,770.4)=EVENT
+36 ; RESPONSE MESSAGE TYPE
SET MAGFDA(101,IENS,770.11)="ACK"
+37 ; PROCESSING ROUTINE
SET MAGFDA(101,IENS,771)="D ENTRY^MAGDHOWA"
+38 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+39 IF $DATA(DIERR)
Begin DoDot:1
+40 DO MES^MAGKIDS("Error in updating subscriber protocol "_X_".")
+41 FOR I=1:1
if '$DATA(MAGERR("DIERR",1,"TEXT",I))
QUIT
Begin DoDot:2
+42 DO MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
+43 QUIT
End DoDot:2
+44 QUIT
End DoDot:1
QUIT
+45 SET SUBSCRIBERIEN=MAGIENS(1)
+46 ;
+47 ; fourth, add the new HLO subscriber to the event driver protocol
+48 SET IENS="+2,"_EVENTDRIVERIEN_","
+49 SET MAGFDA(101.0775,IENS,.01)=SUBSCRIBERIEN
+50 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+51 IF $DATA(DIERR)
Begin DoDot:1
+52 DO MES^MAGKIDS("Error in updating event driver protocol "_X_".")
+53 FOR I=1:1
if '$DATA(MAGERR("DIERR",1,"TEXT",I))
QUIT
Begin DoDot:2
+54 DO MES^MAGKIDS(MAGERR("DIERR",1,"TEXT",I))
+55 QUIT
End DoDot:2
+56 QUIT
End DoDot:1
QUIT
+57 QUIT
+58 ;
+59 ; code to handle adding a mail message for MAGDHOW* errors
+60 ;
ADDMS(INTERVAL) ; Add Message Subjects for Mail Management
+1 NEW I,J,K,MAGFDA,MSG,IEN,MAGERR
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^MAG(2006.1,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 FOR J=1:1:1
SET K=$PIECE($TEXT(TEXT+J),";",3)
Begin DoDot:2
+5 ; Do not re-configure
if $DATA(^MAG(2006.1,IEN,6,"B",K))
QUIT
+6 SET MAGFDA(2006.166,"?+1,"_IEN_",",.01)=K
+7 SET MAGFDA(2006.166,"?+1,"_IEN_",",1)=INTERVAL
+8 DO UPDATE^DIE("","MAGFDA","","MAGERR")
+9 IF $DATA(DIERR)
DO BMES^XPDUTL("Error updating the BP Mail Message Subfile: "_MAGERR("DIERR",1,"TEXT",1))
KILL DIERR,MAGERR
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
ADDMG ; Add Mail Message groups to the Mail Group file (XMB(3.8))
+1 NEW PL,NMSP
+2 SET PL=0
+3 FOR
SET PL=$ORDER(^MAG(2006.1,PL))
if 'PL
QUIT
Begin DoDot:1
+4 SET NMSP=$PIECE($GET(^MAG(2006.1,PL,0)),U,2)
+5 if NMSP=""
QUIT
+6 DO ADD(NMSP)
+7 DO ADDDUZ(NMSP)
+8 QUIT
End DoDot:1
+9 QUIT
ADD(NMSP) ;
+1 NEW J,K,L,MAGFDA,MSG,IEN,MAGIEN,MAGERR
+2 FOR J=1:1:1
SET K=$PIECE($TEXT(TEXT+J),";",3)
Begin DoDot:1
+3 IF '$DATA(^XMB(3.8,"B","MAG_"_NMSP_"_"_$EXTRACT($$TRIM^MAGQBUT4(K),1,20)))
Begin DoDot:2
+4 SET L=$ORDER(^XMB(3.8,"B","MAG_"_NMSP_"_"_$EXTRACT($$TRIM^MAGQBUT4(K),1,20),""))
+5 SET MAGFDA(3.8,"?+"_J_",",.01)="MAG_"_NMSP_"_"_$EXTRACT($$TRIM^MAGQBUT4(K),1,20)
+6 DO UPDATE^DIE("","MAGFDA","MAGIEN","MAGERR")
+7 IF $DATA(DIERR)
DO BMES^XPDUTL("Error Adding Imaging Mail Groups: "_MAGERR("DIERR",1,"TEXT",1))
KILL DIERR,MAGERR,MAGFDA
QUIT
+8 KILL MAGFDA,DIERR,MAGERR
+9 SET MAGFDA(3.8,MAGIEN(J)_",",4)="PU"
+10 DO FILE^DIE("I","MAGFDA","MAGERR")
+11 KILL DIERR,MAGERR,MAGFDA,MAGIEN
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
ADDDUZ(NMSP) ;
+1 NEW J,K,L,MAGFDA,MSG,IEN,MAGIEN,MAGERR
+2 FOR J=1:1:1
SET K=$PIECE($TEXT(TEXT+J),";",3)
Begin DoDot:1
+3 SET L=$ORDER(^XMB(3.8,"B","MAG_"_NMSP_"_"_$EXTRACT($$TRIM^MAGQBUT4(K),1,20),""))
+4 SET MAGFDA(3.81,"?+1,"_L_",",.01)=DUZ
+5 DO UPDATE^DIE("","MAGFDA","MAGIEN","MAGERR")
+6 IF $DATA(DIERR)
DO BMES^XPDUTL("Error Adding Imaging Mail Group member: "_MAGERR("DIERR",1,"TEXT",1))
+7 KILL DIERR,MAGERR,MAGFDA,MAGIEN
End DoDot:1
+8 QUIT
+9 ;
DLKP ; Add Generic Mail groups to BP Message subfile
+1 NEW PL,I,J,MAGFDA,MSGROOT,MG,DIERR,MAGIEN,MAGERR,NMSP
+2 SET PL=0
+3 FOR
SET PL=$ORDER(^MAG(2006.1,PL))
if 'PL
QUIT
Begin DoDot:1
+4 SET I=0
SET NMSP=$PIECE($GET(^MAG(2006.1,PL,0)),U,2)
+5 if NMSP=""
QUIT
+6 FOR
SET I=$ORDER(^MAG(2006.1,PL,6,I))
if 'I
QUIT
Begin DoDot:2
+7 SET MG=$PIECE($GET(^MAG(2006.1,PL,6,I,0)),"^",1)
+8 SET J=$$FIND1^DIC(3.8,"","","MAG_"_NMSP_"_"_$EXTRACT($$TRIM^MAGQBUT4(MG),1,20),"","","MSGROOT")
+9 ; Do not re-configure
if $DATA(^MAG(2006.1,PL,6,I,1,"B",J))
QUIT
+10 IF J
Begin DoDot:3
+11 SET MAGFDA(2006.1662,"+1,"_I_","_PL_",",.01)=J
+12 DO UPDATE^DIE("","MAGFDA","MAGIEN","MAGERR")
+13 IF $DATA(DIERR)
DO BMES^XPDUTL("Error Adding Generic Mail Groups: "_MAGERR("DIERR",1,"TEXT",1))
KILL DIERR,MAGERR
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 KILL MAGFDA,MSGROOT,MAGIEN,MSGROOT
+18 QUIT
TEXT ; Message Subjects
+1 ;;CPRS_DICOM_and_HL7
+2 QUIT
+3 ;+++++ LIST OF NEW REMOTE PROCEDURES
+4 ; have a list in format ;;MAG4 IMAGE LIST
RPCL110 ;
+1 ;;MAG3 TELEREADER CPT CODELOOKUP
+2 QUIT
RPCL130 ;
+1 ;;MAG GET DICOM QUEUE LIST
+2 ;;MAG SEND IMAGE
+3 ;;MAGV CREATE WORK ITEM
+4 ;;MAGV GET WORK ITEM
+5 ;;MAGV GET NEXT WORK ITEM
+6 ;;MAGV FIND WORK ITEM
+7 ;;MAGV UPDATE WORK ITEM
+8 ;;MAGV ADD WORK ITEM TAGS
+9 ;;MAGV DELETE WORK ITEM
+10 QUIT
+11 ;
RPCL079 ;
+1 ;;MAG DICOM CHECK AE TITLE
+2 ;;MAG DICOM GET AE ENTRY
+3 ;;MAG DICOM GET AE ENTRY LOC
+4 ;;MAGVC WI DELETE
+5 ;;MAGVC WI GET
+6 ;;MAGVC WI LIST
+7 ;;MAGVC WI SUBMIT NEW
+8 ;;MAGVC WI UPDATE STATUS
+9 QUIT
+10 ;
RPCL136V ;
+1 ;;MAGV GET RAD DX CODES
+2 ;;MAGV GET RAD IMAGING LOCATIONS
+3 ;;MAGV GET RAD STD RPTS
+4 ;;MAGV GENERATE DICOM UID
+5 QUIT
+6 ;
RPCL137V ;
+1 ;;MAGV GET IRRADIATION DOSE
+2 ;;MAGV ATTACH IRRADIATION DOSE
+3 QUIT
+4 ;
RPCL138V ;
+1 ;;MAGTP GET ACTIVE
+2 ;;MAGTP GET CASES
+3 ;;MAGTP GET CPRS REPORT
+4 ;;MAGTP GET NOTE
+5 ;;MAGTP GET PREFERENCES
+6 ;;MAGTP GET RETENTION DAYS
+7 ;;MAGTP GET SLIDES
+8 ;;MAGTP GET USER
+9 ;;MAGTP PUT NOTE
+10 ;;MAGTP PUT PREFERENCES
+11 ;;MAGTP RESERVE CASE
+12 ;;MAGTP SET RETENTION DAYS
+13 ;;MAGTP USER
+14 ;;MAGG GET TIMEOUT
+15 ;;MAGG INSTALL
+16 ;;MAGG PAT INFO
+17 ;;MAGG VERIFY ESIG
+18 ;;MAGGUPREFGET
+19 ;;MAGGUPREFSAVE
+20 ;;MAGGUSERKEYS
+21 ;;MAG BROKER SECURITY
+22 ;;VAFCTFU CONVERT DFN TO ICN
+23 ;;VAFCTFU CONVERT ICN TO DFN
+24 ;;DG SENSITIVE RECORD ACCESS
+25 ;;DG SENSITIVE RECORD BULLETIN
+26 ;;XWB CREATE CONTEXT
+27 ;;MAG3 SET TIMEOUT
+28 ;;MAGGHSLIST
+29 ;;MAGGHS
+30 QUIT
+31 ;
+32 ; MAGIP138
