MPIF001 ;ALB/RJS/CMC-UTILITY ROUTINE OF APIS ; 10/28/20 8:35pm
;;1.0;MASTER PATIENT INDEX VISTA;**1,3,9,16,18,21,27,33,35,41,45,48,60,76**;30 Apr 99;Build 1
;
; Integration Agreements Utilized:
; ^DPT( - #2070
; ^DPT("AICN" - #2070
; ^DPT("AMPIMIS" - #2070
; EXC^RGHLLOG - #2796
; START^RGHLLOG - #2796
; STOP^RGHLLOG - #2796
;
GETICN(DFN) ; This function returns the ICN, including checksum for a given
; DFN or -1^error message
; INPUT: DFN - ien in Patient file
;
N RETURN,NODE
I $G(DFN)'>0 S RETURN="-1^NO DFN" G EXIT1
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G EXIT1
I '$D(^DPT(DFN,"MPI")) S RETURN="-1^NO MPI NODE" G EXIT1
S NODE=$G(^DPT(DFN,"MPI"))
I $P(NODE,"^",1)'>0 S RETURN="-1^NO ICN" G EXIT1
S RETURN=$P(NODE,"^",1)_"V"_$$CHECKDG^MPIFSPC($P(NODE,"^",1)) ;**48
I '$D(^DPT("AICN",$P(NODE,"^"),DFN)) S ^DPT("AICN",$P(NODE,"^"),DFN)=""
; ^ set AICN x-ref if missing one
EXIT1 ;
Q RETURN
;
GETDFN(ICN) ; Returns DFN (ien Patient file) or -1^error message for a given ICN
; ICN - ICN for a given Patient in the Patient file
N RETURN,DFN
I $G(ICN)'>0 S RETURN="-1^NO ICN" G EXIT2
I ICN["V" S ICN=+ICN
I '$D(^DPT("AICN",ICN)) S RETURN="-1^ICN NOT IN DATABASE" G EXIT2
S DFN=$O(^DPT("AICN",ICN,0))
I $G(DFN)'>0 S RETURN="-1^BAD ICN CROSS-REFERENCE" G EXIT2
I '$D(^DPT(DFN)) K ^DPT("AICN",ICN) S RETURN="-1^ICN NOT IN DATABASE" G EXIT2
;^ **41 - CHECK IF THE DFN HOLDING THIS ICN IS RELATED TO BOGUS XREF
S RETURN=DFN
EXIT2 ;
Q RETURN
;
ICNLC(DFN) ;This API will return an ICN if one exists or create and return
; a Local ICN and update the appropriate fields if a Local was created
; DFN= Patient IEN
; Returns ICN (local or National including checksum) or -1^error msg
N ICN,TMP,CHKSUM,ICNX
I $G(DFN)'>0 Q "-1^No DFN Passed"
D LOCK
S ICN=$$GETICN(DFN)
I +ICN=-1 D
.;no icn create a Local ICN
.S ICN=$$EN2^MPIFAPI()
.S CHKSUM=$P(ICN,"V",2),ICNX=$P(ICN,"V")
.S NOLOCK=""
.I ICNX="" K NOLOCK S ICN="-1^PROBLEM CREATING LOCAL ICN" Q
.S TMP=$$SETICN(DFN,ICNX,CHKSUM)
.I +TMP=-1 K NOLOCK Q
.;**76 - VAMPI-799 (ckn) - Below Full ICN api is now being called by SETICN^MPIF001
.;**60 (elz) MVI_793 new Full ICN field
.;S TMP=$$SETFICN(DFN,ICNX_"V"_CHKSUM)
.S TMP=$$SETLOC(DFN,1)
.S TMP=$$CHANGE(DFN,$P($$SITE^VASITE(),"^"))
.K NOLOCK
D UNLOCK
Q ICN
;
CMOR2(DFN) ; Returns CMOR Site Name or -1^error message
; DFN = Patient IEN
I $G(DFN)'>0 Q "-1^No DFN Passed"
N NODE
S NODE=$$MPINODE^MPIFAPI(DFN)
Q:$P(NODE,"^",3)="" "-1^No CMOR"
Q $$CMORNAME($P(NODE,"^",3))
;
CMORNAME(CIEN) ; Returns CMOR site name or -1^error message
; CIEN - ien from Institution file
;
Q:CIEN="" "-1^No Institution parameter"
N INST
S INST=$$NNT^XUAF4(CIEN)
Q:INST="" "-1^No Institution for that IEN"
Q:$P(INST,"^")="" "-1^No Name for this Institution"
Q $P(INST,"^")
;
GETVCCI(DFN) ; Returns CMOR or -1^error message for a given patient
; DFN - ien of patient in Patient file
N RETURN,NODE,PTR,STANUM
I $G(DFN)'>0 S RETURN="-1^NO DFN" G EXIT3
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G EXIT3
I '$D(^DPT(DFN,"MPI")) S RETURN="-1^NO MPI NODE" G EXIT3
S NODE=$$MPINODE^MPIFAPI(DFN)
S PTR=$P(NODE,"^",3)
I PTR'>0 S RETURN="-1^NO CMOR DEFINED FOR PT" G EXIT3
S STANUM=$P($$NNT^XUAF4(PTR),"^",2)
I STANUM'>0 S RETURN="-1^PTS CMOR IS DANGLING PTR" G EXIT3
S RETURN=STANUM
EXIT3 ;
Q RETURN
;
CHANGE(DFN,VCCI) ;
; ** This function is only to be used by approved packages **
;
; This function updates the CMOR field in the Patient file
; DFN = ien in Patient file
; VCCI = CMOR ien from the institution file
; returned: -1^error message - problem
; 1 - successful
; Exception will be generated if Update to File Fails only
N RETURN,DIQUIET,DIE,DA,DR,Y,X,DIC
S (RETURN,DIQUIET)=1
I $G(DFN)'>0 S RETURN="-1^NO DFN PASSED" G EXIT4
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G EXIT4
I $G(VCCI)="" S RETURN="-1^NO CMOR PASSED" G EXIT4
N CNT,TIEN S DIQUIET=1,CNT=0
I '$D(NOLOCK) D LOCK
; moved to here to fix problem with timing
I $E($$GETICN(DFN),1,3)=$P($$SITE^VASITE(),"^",3) S VCCI=$P($$SITE^VASITE(),"^")
; ^ to be sure site is self for a local icn
S VCCI="`"_VCCI
; ^ Have ien stuff added to use ien instead of station number
REP S DIE="^DPT(",DA=DFN,DR="991.03///^S X=VCCI"
D ^DIE
S CNT=CNT+1
S TIEN=$P($$MPINODE^MPIFAPI(DFN),"^",3)
I "`"_TIEN'=VCCI&(CNT<4) G REP
I "`"_TIEN'=VCCI&(CNT>3) D
.S RETURN="-1^Couldn't Update CMOR"
.D START^RGHLLOG(0)
.D EXC^RGHLLOG(221,"Unable to update CMOR to "_$$STA^XUAF4(TIEN)_" for patient DFN= "_DFN,DFN)
.D STOP^RGHLLOG(0)
I '$D(NOLOCK) D UNLOCK
EXIT4 ;
Q RETURN
;
SETICN(DFN,ICN,CHKSUM) ;
; ** this function is to only be used by approved packages **
;
; This function updates the ICN and ICN Checksum fields in the Patient
; file for a given patient.
; DFN - ien in the Patient file to be updated
; ICN - ICN (without checksum) to be updated
; CHKSUM - ICN checksum
; return: -1^error message - problem
; 1 - successful
N RETURN,DIQUIET,DIE,DA,DR,RGRSICN,Y,ERR
S (RETURN,DIQUIET,RGRSICN)=1
I $G(DFN)'>0 S RETURN="-1^NO DFN PASSED" G EXIT5
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G EXIT5
I $G(ICN)="" S RETURN="-1^NO ICN PASSED" G EXIT5
I $G(CHKSUM)="" S RETURN="-1^NO CHKSUM PASSED" G EXIT5
I +$$GETICN(DFN)>0 I $E(ICN,1,3)=$P($$SITE^VASITE(),"^",3),$E($$GETICN(DFN),1,3)'=$E(ICN,1,3) S RETURN="-1^Don't overwrite national with local" G EXIT5
; ^ stop local from overwriting a national ICN
I +$$GETICN(DFN)>0 I $E(ICN,1,3)=$P($$SITE^VASITE(),"^",3),$E($$GETICN(DFN),1,3)=$P($$SITE^VASITE(),"^",3) S RETURN="-1^Don't overwrite local ICN with another Local ICN" G EXIT5
; ^ STOP LOCAL FROM OVERWRITING ANOTHER LOCAL ICN
I $D(^DPT("AICN",ICN)) D
.Q:DFN=$O(^DPT("AICN",ICN,""))
.I DFN'=($O(^DPT("AICN",ICN,""))) D
..N DFN2 S DFN2=$O(^DPT("AICN",ICN,""))
..I '$D(TWODFN) D TWODFNS^MPIF002(DFN2,DFN,ICN)
.S RETURN="-1^ICN ALREADY IN USE"
G:+RETURN=-1 EXIT5
I '$D(NOLOCK) D LOCK
S DIQUIET=1
S CHKSUM=$$CHECKDG^MPIFSPC(ICN) ;**45 calculate checksum based upon what's passed for ICN and use that to update 991.02
S DIE="^DPT(",DA=DFN,DR="991.01///^S X=ICN;991.02///^S X=CHKSUM"
D ^DIE
;**76 - VAMPI-799 (ckn)-quit if unsuccessful
I +$G(Y)=-1 S RETURN="-1^UNSUCCESSFUL DIE CALL" G EXIT5
I +RETURN>0 D
.K ^DPT("AMPIMIS",DFN)
.I $E(ICN,1,3)=$P($$SITE^VASITE(),"^",3) S ERR=$$SETLOC(DFN,1)
.I $E(ICN,1,3)'=$P($$SITE^VASITE(),"^",3) S ERR=$$SETLOC(DFN,0)
I '$D(NOLOCK) D UNLOCK
;**76 - VAMPI-799 (ckn) - Call Full ICN api
S RETURN=$$SETFICN(DFN,ICN_"V"_CHKSUM)
EXIT5 ;
Q RETURN
;
SETLOC(DFN,DELFLAG) ;
; ** This function should be only used by approved packages **
;
; This function updates the LOCALLY ASSIGNED ICN field in the Patient
; for the given patient
;DFN - ien from Patient file of patient to be updated
;DELFLAG - 1 is to turn the flag on
; - 0 is to turn off the flag
;
N RETURN,DIQUIET,DIE,DA,DR,VALUE,Y
S (RETURN,DIQUIET)=1
I $G(DFN)'>0 S RETURN="-1^NO DFN PASSED" G EXIT6
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G EXIT6
I '$D(NOLOCK) D LOCK
S DIQUIET=1,VALUE=$S($G(DELFLAG)=0:"@",1:1)
S DIE="^DPT(",DA=DFN,DR="991.04///^S X=VALUE"
D ^DIE
I +$G(Y)=-1 S RETURN="-1^UNSUCCESSFUL DIE CALL"
I +RETURN>0 K ^DPT("AMPIMIS",DFN)
I '$D(NOLOCK) D UNLOCK
EXIT6 ;
Q RETURN
;
IFLOCAL(DFN) ; This function is used to see if a patient has a local ICN
; DFN - ien of patient in Patient file
; returned: 0 = patient does not exist, dfn is not defined or no MPI node OR Patient does not have a local ICN
; 1 = patient has a Local ICN assigned
Q:$G(DFN)="" 0
Q:$G(^DPT(DFN,0))="" 0
Q:'$D(^DPT(DFN,"MPI")) 0
Q:$E($$GETICN(DFN),1,3)=$P($$SITE^VASITE,"^",3) 1
Q 0
;
IFVCCI(DFN) ; this function returns 1 if your facility is the CMOR for the given pt
; DFN - ien of patient in Patient file
; returns: 1 = your site in the CMOR for this patient
; -1 = your site is not the CMOR for this patient
; 0^ERROR MSG
N VCCI,SITE
I $G(DFN)'>0 Q "0^No DFN Passed"
S VCCI=$P($$GETVCCI(DFN),"^",1)
S SITE=$P($$SITE^VASITE,"^",3)\1
I $P(VCCI,"^",1)=-1 Q -1
I VCCI'=SITE Q -1
Q 1
;
HL7CMOR(DFN,SEP) ; This function returns the CMOR station number and institution name for
; the given patient.
; DFN = ien for patient in Patient file
; SEP = delimiter to separate station number and name
; returned: Station Number <sep> Institution name
; -1^error message
N RETURN,NODE,PTR,STAT
I $G(DFN)'>0 S RETURN="-1^NO DFN" G EXIT7
I $G(SEP)="" S RETURN="-1^NO FIELD SEPERATOR" G EXIT7
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G EXIT7
I $$MPINODE^MPIFAPI(DFN)<1 S RETURN="-1^NO MPI NODE" G EXIT7
S NODE=$$MPINODE^MPIFAPI(DFN)
S PTR=$P(NODE,"^",3)
I PTR'>0 S RETURN="-1^NO CMOR DEFINED FOR PT" G EXIT7
S STAT=$$NNT^XUAF4(PTR)
I STAT="" S RETURN="-1^PTS CMOR IS DANGLING PTR" G EXIT7
I $P(STAT,"^")="" S RETURN="-1^NO INSTITUTION NAME" G EXIT7
S RETURN=$P(STAT,"^",2)_SEP_$P(STAT,"^")
EXIT7 ;
Q RETURN
;
ICN2DFN(ICN) ; - This function will return a DFN based on the ICN entered
; **60 (elz) MVI_793 this is the new function to use the new single
; ICN field/cross-reference. The full ICN value must be passed in
N RETURN,DFN
I $G(ICN)'>0 S RETURN="-1^NO ICN PASSED IN" G QICN2DFN
I ICN'["V" S RETURN="-1^FULL ICN VALUE REQUIRED" G QICN2DFN
I '$D(^DPT("AFICN",ICN)) S RETURN="-1^ICN NOT FOUND IN DATABASE" G QICN2DFN
S DFN=$O(^DPT("AFICN",ICN,0))
I $G(DFN)'>0 S RETURN="-1^BAD ICN CROSS-REFERENCE" G QICN2DFN
I '$D(^DPT(DFN)) K ^DPT("AFICN",ICN) S RETURN="-1^ICN NOT IN DATABASE" G QICN2DFN
S RETURN=DFN
;
QICN2DFN ;
Q RETURN
;
;
DFN2ICN(DFN) ; This function will return an ICN based on the DFN entered
; **60 (elz) MVI_793 this is the new function to use the new single
; ICN field. The full ICN value will be returned
N RETURN,NODE
I $G(DFN)'>0 S RETURN="-1^NO DFN" G QDFN2ICN
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G QDFN2ICN
I '$D(^DPT(DFN,"MPI")) S RETURN="-1^NO MPI NODE" G QDFN2ICN
S NODE=$G(^DPT(DFN,"MPI"))
I '$L($P(NODE,"^",10)) S RETURN="-1^NO ICN" G QDFN2ICN
S RETURN=$P(NODE,"^",10)
I '$D(^DPT("AFICN",RETURN,DFN)) S ^DPT("AFICN",RETURN,DFN)=""
QDFN2ICN ;
Q RETURN
;
;
SETFICN(DFN,ICN) ; - Set the Full ICN value
; ** this function is to only be used by approved packages **
;**60 (elz) MVI_793 this function will set/update the full ICN value
; in the new FULL ICN field in the Patient file for a given patient
;
; DFN - ien in the Patient file to be updated
; ICN - FULL ICN (with checksum) to be updated
; return: -1^error message - problem
; 1 - successful
N RETURN,DIQUIET,DIE,DA,DR,RGRSICN,Y,ERR
S (RETURN,DIQUIET,RGRSICN)=1
I $G(DFN)'>0 S RETURN="-1^NO DFN PASSED" G QSETFICN
I '$D(^DPT(DFN,0)) S RETURN="-1^PATIENT NOT IN DATABASE" G QSETFICN
I $G(ICN)'>0 S RETURN="-1^NO ICN PASSED" G QSETFICN
I ICN'["V" S RETURN="-1^FULL ICN VALUE REQUIRED" G QSETFICN
I +$$DFN2ICN(DFN)>0 I $E(ICN,1,3)=$P($$SITE^VASITE(),"^",3),$E($$DFN2ICN(DFN),1,3)'=$E(ICN,1,3) S RETURN="-1^Don't overwrite national with local" G QSETFICN
; ^ stop local from overwriting a national ICN
I +$$DFN2ICN(DFN)>0 I $E(ICN,1,3)=$P($$SITE^VASITE(),"^",3),$E($$DFN2ICN(DFN),1,3)=$P($$SITE^VASITE(),"^",3) S RETURN="-1^Don't overwrite local ICN with another Local ICN" G QSETFICN
; ^ STOP LOCAL FROM OVERWRITING ANOTHER LOCAL ICN
I $D(^DPT("AFICN",ICN)) D
.Q:DFN=$O(^DPT("AFICN",ICN,""))
.I DFN'=($O(^DPT("AFICN",ICN,""))) D
..N DFN2 S DFN2=$O(^DPT("AFICN",ICN,""))
..I '$D(TWODFN) D TWODFNS^MPIF002(DFN2,DFN,ICN)
.S RETURN="-1^ICN ALREADY IN USE"
G:+RETURN=-1 QSETFICN
I '$D(NOLOCK) D LOCK
S DIQUIET=1
S DIE="^DPT(",DA=DFN,DR="991.1///^S X=ICN"
D ^DIE
I +$G(Y)=-1 S RETURN="-1^UNSUCCESSFUL DIE CALL"
I +RETURN>0 D
.K ^DPT("AMPIMIS",DFN)
.I $E(ICN,1,3)=$P($$SITE^VASITE(),"^",3) S ERR=$$SETLOC(DFN,1)
.I $E(ICN,1,3)'=$P($$SITE^VASITE(),"^",3) S ERR=$$SETLOC(DFN,0)
I '$D(NOLOCK) D UNLOCK
QSETFICN ;
Q RETURN
;
;
LOCK ;
F L +^DPT(DFN,"MPI"):10 Q:$T
Q
;
UNLOCK ;
L -^DPT(DFN,"MPI")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIF001 12443 printed Sep 23, 2025@19:46:43 Page 2
MPIF001 ;ALB/RJS/CMC-UTILITY ROUTINE OF APIS ; 10/28/20 8:35pm
+1 ;;1.0;MASTER PATIENT INDEX VISTA;**1,3,9,16,18,21,27,33,35,41,45,48,60,76**;30 Apr 99;Build 1
+2 ;
+3 ; Integration Agreements Utilized:
+4 ; ^DPT( - #2070
+5 ; ^DPT("AICN" - #2070
+6 ; ^DPT("AMPIMIS" - #2070
+7 ; EXC^RGHLLOG - #2796
+8 ; START^RGHLLOG - #2796
+9 ; STOP^RGHLLOG - #2796
+10 ;
GETICN(DFN) ; This function returns the ICN, including checksum for a given
+1 ; DFN or -1^error message
+2 ; INPUT: DFN - ien in Patient file
+3 ;
+4 NEW RETURN,NODE
+5 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN"
GOTO EXIT1
+6 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO EXIT1
+7 IF '$DATA(^DPT(DFN,"MPI"))
SET RETURN="-1^NO MPI NODE"
GOTO EXIT1
+8 SET NODE=$GET(^DPT(DFN,"MPI"))
+9 IF $PIECE(NODE,"^",1)'>0
SET RETURN="-1^NO ICN"
GOTO EXIT1
+10 ;**48
SET RETURN=$PIECE(NODE,"^",1)_"V"_$$CHECKDG^MPIFSPC($PIECE(NODE,"^",1))
+11 IF '$DATA(^DPT("AICN",$PIECE(NODE,"^"),DFN))
SET ^DPT("AICN",$PIECE(NODE,"^"),DFN)=""
+12 ; ^ set AICN x-ref if missing one
EXIT1 ;
+1 QUIT RETURN
+2 ;
GETDFN(ICN) ; Returns DFN (ien Patient file) or -1^error message for a given ICN
+1 ; ICN - ICN for a given Patient in the Patient file
+2 NEW RETURN,DFN
+3 IF $GET(ICN)'>0
SET RETURN="-1^NO ICN"
GOTO EXIT2
+4 IF ICN["V"
SET ICN=+ICN
+5 IF '$DATA(^DPT("AICN",ICN))
SET RETURN="-1^ICN NOT IN DATABASE"
GOTO EXIT2
+6 SET DFN=$ORDER(^DPT("AICN",ICN,0))
+7 IF $GET(DFN)'>0
SET RETURN="-1^BAD ICN CROSS-REFERENCE"
GOTO EXIT2
+8 IF '$DATA(^DPT(DFN))
KILL ^DPT("AICN",ICN)
SET RETURN="-1^ICN NOT IN DATABASE"
GOTO EXIT2
+9 ;^ **41 - CHECK IF THE DFN HOLDING THIS ICN IS RELATED TO BOGUS XREF
+10 SET RETURN=DFN
EXIT2 ;
+1 QUIT RETURN
+2 ;
ICNLC(DFN) ;This API will return an ICN if one exists or create and return
+1 ; a Local ICN and update the appropriate fields if a Local was created
+2 ; DFN= Patient IEN
+3 ; Returns ICN (local or National including checksum) or -1^error msg
+4 NEW ICN,TMP,CHKSUM,ICNX
+5 IF $GET(DFN)'>0
QUIT "-1^No DFN Passed"
+6 DO LOCK
+7 SET ICN=$$GETICN(DFN)
+8 IF +ICN=-1
Begin DoDot:1
+9 ;no icn create a Local ICN
+10 SET ICN=$$EN2^MPIFAPI()
+11 SET CHKSUM=$PIECE(ICN,"V",2)
SET ICNX=$PIECE(ICN,"V")
+12 SET NOLOCK=""
+13 IF ICNX=""
KILL NOLOCK
SET ICN="-1^PROBLEM CREATING LOCAL ICN"
QUIT
+14 SET TMP=$$SETICN(DFN,ICNX,CHKSUM)
+15 IF +TMP=-1
KILL NOLOCK
QUIT
+16 ;**76 - VAMPI-799 (ckn) - Below Full ICN api is now being called by SETICN^MPIF001
+17 ;**60 (elz) MVI_793 new Full ICN field
+18 ;S TMP=$$SETFICN(DFN,ICNX_"V"_CHKSUM)
+19 SET TMP=$$SETLOC(DFN,1)
+20 SET TMP=$$CHANGE(DFN,$PIECE($$SITE^VASITE(),"^"))
+21 KILL NOLOCK
End DoDot:1
+22 DO UNLOCK
+23 QUIT ICN
+24 ;
CMOR2(DFN) ; Returns CMOR Site Name or -1^error message
+1 ; DFN = Patient IEN
+2 IF $GET(DFN)'>0
QUIT "-1^No DFN Passed"
+3 NEW NODE
+4 SET NODE=$$MPINODE^MPIFAPI(DFN)
+5 if $PIECE(NODE,"^",3)=""
QUIT "-1^No CMOR"
+6 QUIT $$CMORNAME($PIECE(NODE,"^",3))
+7 ;
CMORNAME(CIEN) ; Returns CMOR site name or -1^error message
+1 ; CIEN - ien from Institution file
+2 ;
+3 if CIEN=""
QUIT "-1^No Institution parameter"
+4 NEW INST
+5 SET INST=$$NNT^XUAF4(CIEN)
+6 if INST=""
QUIT "-1^No Institution for that IEN"
+7 if $PIECE(INST,"^")=""
QUIT "-1^No Name for this Institution"
+8 QUIT $PIECE(INST,"^")
+9 ;
GETVCCI(DFN) ; Returns CMOR or -1^error message for a given patient
+1 ; DFN - ien of patient in Patient file
+2 NEW RETURN,NODE,PTR,STANUM
+3 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN"
GOTO EXIT3
+4 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO EXIT3
+5 IF '$DATA(^DPT(DFN,"MPI"))
SET RETURN="-1^NO MPI NODE"
GOTO EXIT3
+6 SET NODE=$$MPINODE^MPIFAPI(DFN)
+7 SET PTR=$PIECE(NODE,"^",3)
+8 IF PTR'>0
SET RETURN="-1^NO CMOR DEFINED FOR PT"
GOTO EXIT3
+9 SET STANUM=$PIECE($$NNT^XUAF4(PTR),"^",2)
+10 IF STANUM'>0
SET RETURN="-1^PTS CMOR IS DANGLING PTR"
GOTO EXIT3
+11 SET RETURN=STANUM
EXIT3 ;
+1 QUIT RETURN
+2 ;
CHANGE(DFN,VCCI) ;
+1 ; ** This function is only to be used by approved packages **
+2 ;
+3 ; This function updates the CMOR field in the Patient file
+4 ; DFN = ien in Patient file
+5 ; VCCI = CMOR ien from the institution file
+6 ; returned: -1^error message - problem
+7 ; 1 - successful
+8 ; Exception will be generated if Update to File Fails only
+9 NEW RETURN,DIQUIET,DIE,DA,DR,Y,X,DIC
+10 SET (RETURN,DIQUIET)=1
+11 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN PASSED"
GOTO EXIT4
+12 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO EXIT4
+13 IF $GET(VCCI)=""
SET RETURN="-1^NO CMOR PASSED"
GOTO EXIT4
+14 NEW CNT,TIEN
SET DIQUIET=1
SET CNT=0
+15 IF '$DATA(NOLOCK)
DO LOCK
+16 ; moved to here to fix problem with timing
+17 IF $EXTRACT($$GETICN(DFN),1,3)=$PIECE($$SITE^VASITE(),"^",3)
SET VCCI=$PIECE($$SITE^VASITE(),"^")
+18 ; ^ to be sure site is self for a local icn
+19 SET VCCI="`"_VCCI
+20 ; ^ Have ien stuff added to use ien instead of station number
REP SET DIE="^DPT("
SET DA=DFN
SET DR="991.03///^S X=VCCI"
+1 DO ^DIE
+2 SET CNT=CNT+1
+3 SET TIEN=$PIECE($$MPINODE^MPIFAPI(DFN),"^",3)
+4 IF "`"_TIEN'=VCCI&(CNT<4)
GOTO REP
+5 IF "`"_TIEN'=VCCI&(CNT>3)
Begin DoDot:1
+6 SET RETURN="-1^Couldn't Update CMOR"
+7 DO START^RGHLLOG(0)
+8 DO EXC^RGHLLOG(221,"Unable to update CMOR to "_$$STA^XUAF4(TIEN)_" for patient DFN= "_DFN,DFN)
+9 DO STOP^RGHLLOG(0)
End DoDot:1
+10 IF '$DATA(NOLOCK)
DO UNLOCK
EXIT4 ;
+1 QUIT RETURN
+2 ;
SETICN(DFN,ICN,CHKSUM) ;
+1 ; ** this function is to only be used by approved packages **
+2 ;
+3 ; This function updates the ICN and ICN Checksum fields in the Patient
+4 ; file for a given patient.
+5 ; DFN - ien in the Patient file to be updated
+6 ; ICN - ICN (without checksum) to be updated
+7 ; CHKSUM - ICN checksum
+8 ; return: -1^error message - problem
+9 ; 1 - successful
+10 NEW RETURN,DIQUIET,DIE,DA,DR,RGRSICN,Y,ERR
+11 SET (RETURN,DIQUIET,RGRSICN)=1
+12 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN PASSED"
GOTO EXIT5
+13 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO EXIT5
+14 IF $GET(ICN)=""
SET RETURN="-1^NO ICN PASSED"
GOTO EXIT5
+15 IF $GET(CHKSUM)=""
SET RETURN="-1^NO CHKSUM PASSED"
GOTO EXIT5
+16 IF +$$GETICN(DFN)>0
IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE(),"^",3)
IF $EXTRACT($$GETICN(DFN),1,3)'=$EXTRACT(ICN,1,3)
SET RETURN="-1^Don't overwrite national with local"
GOTO EXIT5
+17 ; ^ stop local from overwriting a national ICN
+18 IF +$$GETICN(DFN)>0
IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE(),"^",3)
IF $EXTRACT($$GETICN(DFN),1,3)=$PIECE($$SITE^VASITE(),"^",3)
SET RETURN="-1^Don't overwrite local ICN with another Local ICN"
GOTO EXIT5
+19 ; ^ STOP LOCAL FROM OVERWRITING ANOTHER LOCAL ICN
+20 IF $DATA(^DPT("AICN",ICN))
Begin DoDot:1
+21 if DFN=$ORDER(^DPT("AICN",ICN,""))
QUIT
+22 IF DFN'=($ORDER(^DPT("AICN",ICN,"")))
Begin DoDot:2
+23 NEW DFN2
SET DFN2=$ORDER(^DPT("AICN",ICN,""))
+24 IF '$DATA(TWODFN)
DO TWODFNS^MPIF002(DFN2,DFN,ICN)
End DoDot:2
+25 SET RETURN="-1^ICN ALREADY IN USE"
End DoDot:1
+26 if +RETURN=-1
GOTO EXIT5
+27 IF '$DATA(NOLOCK)
DO LOCK
+28 SET DIQUIET=1
+29 ;**45 calculate checksum based upon what's passed for ICN and use that to update 991.02
SET CHKSUM=$$CHECKDG^MPIFSPC(ICN)
+30 SET DIE="^DPT("
SET DA=DFN
SET DR="991.01///^S X=ICN;991.02///^S X=CHKSUM"
+31 DO ^DIE
+32 ;**76 - VAMPI-799 (ckn)-quit if unsuccessful
+33 IF +$GET(Y)=-1
SET RETURN="-1^UNSUCCESSFUL DIE CALL"
GOTO EXIT5
+34 IF +RETURN>0
Begin DoDot:1
+35 KILL ^DPT("AMPIMIS",DFN)
+36 IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE(),"^",3)
SET ERR=$$SETLOC(DFN,1)
+37 IF $EXTRACT(ICN,1,3)'=$PIECE($$SITE^VASITE(),"^",3)
SET ERR=$$SETLOC(DFN,0)
End DoDot:1
+38 IF '$DATA(NOLOCK)
DO UNLOCK
+39 ;**76 - VAMPI-799 (ckn) - Call Full ICN api
+40 SET RETURN=$$SETFICN(DFN,ICN_"V"_CHKSUM)
EXIT5 ;
+1 QUIT RETURN
+2 ;
SETLOC(DFN,DELFLAG) ;
+1 ; ** This function should be only used by approved packages **
+2 ;
+3 ; This function updates the LOCALLY ASSIGNED ICN field in the Patient
+4 ; for the given patient
+5 ;DFN - ien from Patient file of patient to be updated
+6 ;DELFLAG - 1 is to turn the flag on
+7 ; - 0 is to turn off the flag
+8 ;
+9 NEW RETURN,DIQUIET,DIE,DA,DR,VALUE,Y
+10 SET (RETURN,DIQUIET)=1
+11 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN PASSED"
GOTO EXIT6
+12 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO EXIT6
+13 IF '$DATA(NOLOCK)
DO LOCK
+14 SET DIQUIET=1
SET VALUE=$SELECT($GET(DELFLAG)=0:"@",1:1)
+15 SET DIE="^DPT("
SET DA=DFN
SET DR="991.04///^S X=VALUE"
+16 DO ^DIE
+17 IF +$GET(Y)=-1
SET RETURN="-1^UNSUCCESSFUL DIE CALL"
+18 IF +RETURN>0
KILL ^DPT("AMPIMIS",DFN)
+19 IF '$DATA(NOLOCK)
DO UNLOCK
EXIT6 ;
+1 QUIT RETURN
+2 ;
IFLOCAL(DFN) ; This function is used to see if a patient has a local ICN
+1 ; DFN - ien of patient in Patient file
+2 ; returned: 0 = patient does not exist, dfn is not defined or no MPI node OR Patient does not have a local ICN
+3 ; 1 = patient has a Local ICN assigned
+4 if $GET(DFN)=""
QUIT 0
+5 if $GET(^DPT(DFN,0))=""
QUIT 0
+6 if '$DATA(^DPT(DFN,"MPI"))
QUIT 0
+7 if $EXTRACT($$GETICN(DFN),1,3)=$PIECE($$SITE^VASITE,"^",3)
QUIT 1
+8 QUIT 0
+9 ;
IFVCCI(DFN) ; this function returns 1 if your facility is the CMOR for the given pt
+1 ; DFN - ien of patient in Patient file
+2 ; returns: 1 = your site in the CMOR for this patient
+3 ; -1 = your site is not the CMOR for this patient
+4 ; 0^ERROR MSG
+5 NEW VCCI,SITE
+6 IF $GET(DFN)'>0
QUIT "0^No DFN Passed"
+7 SET VCCI=$PIECE($$GETVCCI(DFN),"^",1)
+8 SET SITE=$PIECE($$SITE^VASITE,"^",3)\1
+9 IF $PIECE(VCCI,"^",1)=-1
QUIT -1
+10 IF VCCI'=SITE
QUIT -1
+11 QUIT 1
+12 ;
HL7CMOR(DFN,SEP) ; This function returns the CMOR station number and institution name for
+1 ; the given patient.
+2 ; DFN = ien for patient in Patient file
+3 ; SEP = delimiter to separate station number and name
+4 ; returned: Station Number <sep> Institution name
+5 ; -1^error message
+6 NEW RETURN,NODE,PTR,STAT
+7 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN"
GOTO EXIT7
+8 IF $GET(SEP)=""
SET RETURN="-1^NO FIELD SEPERATOR"
GOTO EXIT7
+9 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO EXIT7
+10 IF $$MPINODE^MPIFAPI(DFN)<1
SET RETURN="-1^NO MPI NODE"
GOTO EXIT7
+11 SET NODE=$$MPINODE^MPIFAPI(DFN)
+12 SET PTR=$PIECE(NODE,"^",3)
+13 IF PTR'>0
SET RETURN="-1^NO CMOR DEFINED FOR PT"
GOTO EXIT7
+14 SET STAT=$$NNT^XUAF4(PTR)
+15 IF STAT=""
SET RETURN="-1^PTS CMOR IS DANGLING PTR"
GOTO EXIT7
+16 IF $PIECE(STAT,"^")=""
SET RETURN="-1^NO INSTITUTION NAME"
GOTO EXIT7
+17 SET RETURN=$PIECE(STAT,"^",2)_SEP_$PIECE(STAT,"^")
EXIT7 ;
+1 QUIT RETURN
+2 ;
ICN2DFN(ICN) ; - This function will return a DFN based on the ICN entered
+1 ; **60 (elz) MVI_793 this is the new function to use the new single
+2 ; ICN field/cross-reference. The full ICN value must be passed in
+3 NEW RETURN,DFN
+4 IF $GET(ICN)'>0
SET RETURN="-1^NO ICN PASSED IN"
GOTO QICN2DFN
+5 IF ICN'["V"
SET RETURN="-1^FULL ICN VALUE REQUIRED"
GOTO QICN2DFN
+6 IF '$DATA(^DPT("AFICN",ICN))
SET RETURN="-1^ICN NOT FOUND IN DATABASE"
GOTO QICN2DFN
+7 SET DFN=$ORDER(^DPT("AFICN",ICN,0))
+8 IF $GET(DFN)'>0
SET RETURN="-1^BAD ICN CROSS-REFERENCE"
GOTO QICN2DFN
+9 IF '$DATA(^DPT(DFN))
KILL ^DPT("AFICN",ICN)
SET RETURN="-1^ICN NOT IN DATABASE"
GOTO QICN2DFN
+10 SET RETURN=DFN
+11 ;
QICN2DFN ;
+1 QUIT RETURN
+2 ;
+3 ;
DFN2ICN(DFN) ; This function will return an ICN based on the DFN entered
+1 ; **60 (elz) MVI_793 this is the new function to use the new single
+2 ; ICN field. The full ICN value will be returned
+3 NEW RETURN,NODE
+4 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN"
GOTO QDFN2ICN
+5 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO QDFN2ICN
+6 IF '$DATA(^DPT(DFN,"MPI"))
SET RETURN="-1^NO MPI NODE"
GOTO QDFN2ICN
+7 SET NODE=$GET(^DPT(DFN,"MPI"))
+8 IF '$LENGTH($PIECE(NODE,"^",10))
SET RETURN="-1^NO ICN"
GOTO QDFN2ICN
+9 SET RETURN=$PIECE(NODE,"^",10)
+10 IF '$DATA(^DPT("AFICN",RETURN,DFN))
SET ^DPT("AFICN",RETURN,DFN)=""
QDFN2ICN ;
+1 QUIT RETURN
+2 ;
+3 ;
SETFICN(DFN,ICN) ; - Set the Full ICN value
+1 ; ** this function is to only be used by approved packages **
+2 ;**60 (elz) MVI_793 this function will set/update the full ICN value
+3 ; in the new FULL ICN field in the Patient file for a given patient
+4 ;
+5 ; DFN - ien in the Patient file to be updated
+6 ; ICN - FULL ICN (with checksum) to be updated
+7 ; return: -1^error message - problem
+8 ; 1 - successful
+9 NEW RETURN,DIQUIET,DIE,DA,DR,RGRSICN,Y,ERR
+10 SET (RETURN,DIQUIET,RGRSICN)=1
+11 IF $GET(DFN)'>0
SET RETURN="-1^NO DFN PASSED"
GOTO QSETFICN
+12 IF '$DATA(^DPT(DFN,0))
SET RETURN="-1^PATIENT NOT IN DATABASE"
GOTO QSETFICN
+13 IF $GET(ICN)'>0
SET RETURN="-1^NO ICN PASSED"
GOTO QSETFICN
+14 IF ICN'["V"
SET RETURN="-1^FULL ICN VALUE REQUIRED"
GOTO QSETFICN
+15 IF +$$DFN2ICN(DFN)>0
IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE(),"^",3)
IF $EXTRACT($$DFN2ICN(DFN),1,3)'=$EXTRACT(ICN,1,3)
SET RETURN="-1^Don't overwrite national with local"
GOTO QSETFICN
+16 ; ^ stop local from overwriting a national ICN
+17 IF +$$DFN2ICN(DFN)>0
IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE(),"^",3)
IF $EXTRACT($$DFN2ICN(DFN),1,3)=$PIECE($$SITE^VASITE(),"^",3)
SET RETURN="-1^Don't overwrite local ICN with another Local ICN"
GOTO QSETFICN
+18 ; ^ STOP LOCAL FROM OVERWRITING ANOTHER LOCAL ICN
+19 IF $DATA(^DPT("AFICN",ICN))
Begin DoDot:1
+20 if DFN=$ORDER(^DPT("AFICN",ICN,""))
QUIT
+21 IF DFN'=($ORDER(^DPT("AFICN",ICN,"")))
Begin DoDot:2
+22 NEW DFN2
SET DFN2=$ORDER(^DPT("AFICN",ICN,""))
+23 IF '$DATA(TWODFN)
DO TWODFNS^MPIF002(DFN2,DFN,ICN)
End DoDot:2
+24 SET RETURN="-1^ICN ALREADY IN USE"
End DoDot:1
+25 if +RETURN=-1
GOTO QSETFICN
+26 IF '$DATA(NOLOCK)
DO LOCK
+27 SET DIQUIET=1
+28 SET DIE="^DPT("
SET DA=DFN
SET DR="991.1///^S X=ICN"
+29 DO ^DIE
+30 IF +$GET(Y)=-1
SET RETURN="-1^UNSUCCESSFUL DIE CALL"
+31 IF +RETURN>0
Begin DoDot:1
+32 KILL ^DPT("AMPIMIS",DFN)
+33 IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE(),"^",3)
SET ERR=$$SETLOC(DFN,1)
+34 IF $EXTRACT(ICN,1,3)'=$PIECE($$SITE^VASITE(),"^",3)
SET ERR=$$SETLOC(DFN,0)
End DoDot:1
+35 IF '$DATA(NOLOCK)
DO UNLOCK
QSETFICN ;
+1 QUIT RETURN
+2 ;
+3 ;
LOCK ;
+1 FOR
LOCK +^DPT(DFN,"MPI"):10
if $TEST
QUIT
+2 QUIT
+3 ;
UNLOCK ;
+1 LOCK -^DPT(DFN,"MPI")
+2 QUIT
