- RGFIPM ;ALB/CJM-PROCESS FACILITY INTEGRATION MESSAGE ;08/27/99
- ;;1.0;CLINICAL INFO RESOURCE NETWORK;**5**;30 Apr 99
- ;
- XCHANGE(DFN,LEGSN,PRIMSN,ERROR) ;
- ;Description: If the CMOR is the legacy site it changes to the
- ;primary site. If the legacy system is on the treating facility list
- ;it is removed. If the primary system is not on the treating facility
- ;list it is added.The subscription for the legacy system is terminated.
- ;If the primary system is not on the subscriber list it is added.
- ;
- ;Input:
- ; DFN - ien of patient (required)
- ; LEGSN- station # of the legacy site (required)-
- ; PRIMSN - station # of the primary site (required)
- ;Output:
- ; Function Value - 0 if any error condition encountered, 1 otherwise
- ; ERROR() - (optional,pass by reference) - an array of error messages
- ;
- ;Variables:
- ; PRIMIEN - ien of the primary site in the Institution file
- ; PRIMLINK - name of logical link for primary site
- ; FOUNDERR - flag set to 1 if an error is found
- ; MPIDATA() - array containing MPI data for this patient
- ;
- N PRIMIEN,PRIMLINK,FOUNDERR,MPIDATA,RETURN,LEGIEN
- ;
- D
- .S FOUNDERR=0
- .I DFN,LEGSN,PRIMSN
- .E D ADDERROR("INPUT PARAMETER MISSING, TAG=XCHANGE,RTN=RGFIPM",6) Q
- .;
- .S PRIMIEN=$$LKUP^XUAF4(PRIMSN)
- .I 'PRIMIEN D ADDERROR("INSTITUTION LOOKUP FAILED, STATION# = "_PRIMSN,229) Q
- .S LEGIEN=$$LKUP^XUAF4(LEGSN)
- .I 'LEGIEN D ADDERROR("INSTITUTION LOOKUP FAILED, STATION# = "_LEGSN,229)
- .;
- .D GETALL^RGFIU(DFN,.MPIDATA)
- .;
- .;if the legacy site is the CMOR change it to the primary site
- .I MPIDATA("CMOR")=LEGSN,($$CHANGE^MPIF001(DFN,PRIMIEN)'=1) D ADDERROR("ERROR CHANGING CMOR TO "_PRIMSN,6)
- .;
- .;if the legacy system is on the TF list, remove it
- .I $D(MPIDATA("TF",LEGSN)) S RETURN=$$DELETETF^VAFCTFU(MPIDATA("ICN"),MPIDATA("TF",LEGSN,"INSTIEN")) I +RETURN D ADDERROR("FAILURE TO DELETE TREATING FACILITY = "_LEGSN,6)
- .;
- .;if the primary site is not on the TF list, then add it OR
- .;its on the Tf list but with an earlier date than the legacy and legacy has an event reason OR legacy has an event reason and primary doesn't, change it
- .I ('$D(MPIDATA("TF",PRIMSN)))!($G(MPIDATA("TF",PRIMSN,"LASTDATE"))<$G(MPIDATA("TF",LEGSN,"LASTDATE"))&$G(MPIDATA("TF",LEGSN,"EVENT")))!($G(MPIDATA("TF",LEGSN,"EVENT"))&('$G(MPIDATA("TF",PRIMSN,"EVENT")))) D
- ..;should not be necessar to delete old TF entry for primary before calling FILE^VACTFU
- ..;I $D(MPIDATA("TF",PRIMSN)) S RETURN=$$DELETETF^VAFCTFU(MPIDATA("ICN"),MPIDATA("TF",PRIMSN,"INSTIEN"))
- ..;
- ..D FILE^VAFCTFU(DFN,PRIMIEN_"^"_$G(MPIDATA("TF",LEGSN,"LASTDATE"))_"^"_$G(MPIDATA("TF",LEGSN,"EVENT")),1)
- .;
- .Q:'MPIDATA("SUB")
- .;Terminate the subscription of legacy site
- .I LEGIEN,LEGIEN'=+$$SITE^VASITE D UPD^HLSUB(MPIDATA("SUB"),$$GETLINK^RGFIU(LEGIEN),,,$$NOW^XLFDT)
- .;
- .;if the primary site is not on the subscription list then add it - unless this site is the primary site!
- .D
- ..Q:(($P($$SITE^VASITE(),"^",3))=PRIMSN)
- ..;Add primary site as a subscriber
- ..N ERR
- ..;Get the logical link for the primary site
- ..S PRIMLINK=$$GETLINK^RGFIU(PRIMIEN)
- ..I PRIMLINK="" D ADDERROR("FAILURE TO ADD SUBSCRIPTION FOR STATION# = "_PRIMSN,224) Q
- ..D UPD^HLSUB(MPIDATA("SUB"),PRIMLINK,0,,"@",,.ERR)
- ..I $O(ERR(0)) D ADDERROR("FAILURE TO ADD SUBSCRIPTION FOR STATION# = "_PRIMSN,6)
- Q $S(FOUNDERR:0,1:1)
- ;
- ADDERROR(MSG,CODE) ;
- ;Description: Puts the error message on a list. If an exception type code is passed the exception handler will be called.
- ;
- ;Input:
- ; MSG - message text
- ; CODE - a CIRN exception type (optional)
- ; ERROR() - this is the array where errors are being tracked
- ; DFN - the patient DFN should be defined
- ;Output:
- ; ERROR() array has the addtional error entered
- ; FOUNDERR is set to 1, is a flag indicating that an error was encountered
- ;
- N NEXT
- S FOUNDERR=1
- S NEXT=($O(ERROR(-1))+1)
- S ERROR(NEXT)=MSG
- S ERROR(NEXT,"CODE")=$G(CODE)
- I $G(CODE),$G(DFN) D EXC^RGFIU(CODE,"FACILITY INTEGRATION ERROR: "_$P($$ERROR^RGFIPM1(MSG,CODE,$$ICN^RGFIU(DFN)),"^",2),DFN)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGFIPM 4109 printed Feb 18, 2025@23:08:13 Page 2
- RGFIPM ;ALB/CJM-PROCESS FACILITY INTEGRATION MESSAGE ;08/27/99
- +1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**5**;30 Apr 99
- +2 ;
- XCHANGE(DFN,LEGSN,PRIMSN,ERROR) ;
- +1 ;Description: If the CMOR is the legacy site it changes to the
- +2 ;primary site. If the legacy system is on the treating facility list
- +3 ;it is removed. If the primary system is not on the treating facility
- +4 ;list it is added.The subscription for the legacy system is terminated.
- +5 ;If the primary system is not on the subscriber list it is added.
- +6 ;
- +7 ;Input:
- +8 ; DFN - ien of patient (required)
- +9 ; LEGSN- station # of the legacy site (required)-
- +10 ; PRIMSN - station # of the primary site (required)
- +11 ;Output:
- +12 ; Function Value - 0 if any error condition encountered, 1 otherwise
- +13 ; ERROR() - (optional,pass by reference) - an array of error messages
- +14 ;
- +15 ;Variables:
- +16 ; PRIMIEN - ien of the primary site in the Institution file
- +17 ; PRIMLINK - name of logical link for primary site
- +18 ; FOUNDERR - flag set to 1 if an error is found
- +19 ; MPIDATA() - array containing MPI data for this patient
- +20 ;
- +21 NEW PRIMIEN,PRIMLINK,FOUNDERR,MPIDATA,RETURN,LEGIEN
- +22 ;
- +23 Begin DoDot:1
- +24 SET FOUNDERR=0
- +25 IF DFN
- IF LEGSN
- IF PRIMSN
- +26 IF '$TEST
- DO ADDERROR("INPUT PARAMETER MISSING, TAG=XCHANGE,RTN=RGFIPM",6)
- QUIT
- +27 ;
- +28 SET PRIMIEN=$$LKUP^XUAF4(PRIMSN)
- +29 IF 'PRIMIEN
- DO ADDERROR("INSTITUTION LOOKUP FAILED, STATION# = "_PRIMSN,229)
- QUIT
- +30 SET LEGIEN=$$LKUP^XUAF4(LEGSN)
- +31 IF 'LEGIEN
- DO ADDERROR("INSTITUTION LOOKUP FAILED, STATION# = "_LEGSN,229)
- +32 ;
- +33 DO GETALL^RGFIU(DFN,.MPIDATA)
- +34 ;
- +35 ;if the legacy site is the CMOR change it to the primary site
- +36 IF MPIDATA("CMOR")=LEGSN
- IF ($$CHANGE^MPIF001(DFN,PRIMIEN)'=1)
- DO ADDERROR("ERROR CHANGING CMOR TO "_PRIMSN,6)
- +37 ;
- +38 ;if the legacy system is on the TF list, remove it
- +39 IF $DATA(MPIDATA("TF",LEGSN))
- SET RETURN=$$DELETETF^VAFCTFU(MPIDATA("ICN"),MPIDATA("TF",LEGSN,"INSTIEN"))
- IF +RETURN
- DO ADDERROR("FAILURE TO DELETE TREATING FACILITY = "_LEGSN,6)
- +40 ;
- +41 ;if the primary site is not on the TF list, then add it OR
- +42 ;its on the Tf list but with an earlier date than the legacy and legacy has an event reason OR legacy has an event reason and primary doesn't, change it
- +43 IF ('$DATA(MPIDATA("TF",PRIMSN)))!($GET(MPIDATA("TF",PRIMSN,"LASTDATE"))<$GET(MPIDATA("TF",LEGSN,"LASTDATE"))&$GET(MPIDATA("TF",LEGSN,"EVENT")))!($GET(MPIDATA("TF",LEGSN,"EVENT"))&('$GET(MPIDATA("TF",PRIMSN,"EVENT"))))
- Begin DoDot:2
- +44 ;should not be necessar to delete old TF entry for primary before calling FILE^VACTFU
- +45 ;I $D(MPIDATA("TF",PRIMSN)) S RETURN=$$DELETETF^VAFCTFU(MPIDATA("ICN"),MPIDATA("TF",PRIMSN,"INSTIEN"))
- +46 ;
- +47 DO FILE^VAFCTFU(DFN,PRIMIEN_"^"_$GET(MPIDATA("TF",LEGSN,"LASTDATE"))_"^"_$GET(MPIDATA("TF",LEGSN,"EVENT")),1)
- End DoDot:2
- +48 ;
- +49 if 'MPIDATA("SUB")
- QUIT
- +50 ;Terminate the subscription of legacy site
- +51 IF LEGIEN
- IF LEGIEN'=+$$SITE^VASITE
- DO UPD^HLSUB(MPIDATA("SUB"),$$GETLINK^RGFIU(LEGIEN),,,$$NOW^XLFDT)
- +52 ;
- +53 ;if the primary site is not on the subscription list then add it - unless this site is the primary site!
- +54 Begin DoDot:2
- +55 if (($PIECE($$SITE^VASITE(),"^",3))=PRIMSN)
- QUIT
- +56 ;Add primary site as a subscriber
- +57 NEW ERR
- +58 ;Get the logical link for the primary site
- +59 SET PRIMLINK=$$GETLINK^RGFIU(PRIMIEN)
- +60 IF PRIMLINK=""
- DO ADDERROR("FAILURE TO ADD SUBSCRIPTION FOR STATION# = "_PRIMSN,224)
- QUIT
- +61 DO UPD^HLSUB(MPIDATA("SUB"),PRIMLINK,0,,"@",,.ERR)
- +62 IF $ORDER(ERR(0))
- DO ADDERROR("FAILURE TO ADD SUBSCRIPTION FOR STATION# = "_PRIMSN,6)
- End DoDot:2
- End DoDot:1
- +63 QUIT $SELECT(FOUNDERR:0,1:1)
- +64 ;
- ADDERROR(MSG,CODE) ;
- +1 ;Description: Puts the error message on a list. If an exception type code is passed the exception handler will be called.
- +2 ;
- +3 ;Input:
- +4 ; MSG - message text
- +5 ; CODE - a CIRN exception type (optional)
- +6 ; ERROR() - this is the array where errors are being tracked
- +7 ; DFN - the patient DFN should be defined
- +8 ;Output:
- +9 ; ERROR() array has the addtional error entered
- +10 ; FOUNDERR is set to 1, is a flag indicating that an error was encountered
- +11 ;
- +12 NEW NEXT
- +13 SET FOUNDERR=1
- +14 SET NEXT=($ORDER(ERROR(-1))+1)
- +15 SET ERROR(NEXT)=MSG
- +16 SET ERROR(NEXT,"CODE")=$GET(CODE)
- +17 IF $GET(CODE)
- IF $GET(DFN)
- DO EXC^RGFIU(CODE,"FACILITY INTEGRATION ERROR: "_$PIECE($$ERROR^RGFIPM1(MSG,CODE,$$ICN^RGFIU(DFN)),"^",2),DFN)
- +18 QUIT