source: WorldVistAEHR/trunk/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFAPI1.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1MPIFAPI1 ;CMC/BP-APIS FOR MPI - CONTINUED ;DEC 21, 1998
2 ;;1.0; MASTER PATIENT INDEX VISTA ;**37,41**;30 Apr 99
3 ;
4 ; Integration Agreements Utilized:
5 ; ^DPT( - #2070 and #4079
6 ; ^DPT("AICN", ^DPT("AMPIMIS", ^DPT("ASCN2" - #2070
7 ; EXC, START, STOP^RGHLLOG - #2796
8 ;
9UPDATE(DFN,ARR,MPISILNT,REMOVE) ;api to edit 'mpi','mpifhis' and 'mpicmor' nodes
10 ;**37 UPDATE module moved 3/30/05 from MPIFAPI into MPIFAPI1.
11 ;
12 ;DFN - patient IEN
13 ;ARR - array in the format listed below
14 ; MPI node by passing in ARR(field#)=value
15 ; **NOTE: 991.04 is only edited based on the edit of 991.01
16 ; 991.03 should be passed with either "@" or IEN in File 4
17 ; MPIFHIS node by passing ARR(992)=old ICN to remove from multiple
18 ; MPICMOR node by passing ARR(993)=old CMOR to remove from multiple
19 ;MPISILNT(optional) - 0 to not suppress exceptions (default)
20 ; 1 to suppress exceptions
21 ;REMOVE (optional) - 0 default - use FM to delete MPI values
22 ; 1 to delete outside FM the MPI fields -- should only be used to clean up the stub record's mpi data, including history for icn and cmor
23 ;Returns : -1^error message if unable to update fields
24 ; 0 if successfully updated fields
25 ;
26 N MPIRETN,MPIX,VALUE,ICN,SCN,ICN2,DFN2
27 I DFN'>0 Q "-1^DFN passed into UPDATE^MPIFAPI not greater than 0"
28 Q:'$D(^DPT(DFN,0)) "-1^DFN "_DFN_" does not exist"
29 S MPIRETN=0,RGRSICN=""
30 F L +^DPT("MPI",DFN):10 Q:$T
31 I $D(REMOVE) D CLEAN^MPIF002(DFN,.ARR,.MPIRETN) L -^DPT("MPI",DFN) Q MPIRETN
32 I $D(@ARR@(991.01)) D
33 .I '$D(@ARR@(991.02)) S MPIRETN="-1^ICN "_ICN_", passed without checksum" Q
34 .;quit if local is going to overwrite national
35 .S ICN=+$$GETICN^MPIF001(DFN) I ICN>0 I $E(@ARR@(991.01),1,3)=$P($$SITE^VASITE(),"^",3),$E(ICN,1,3)'=$E(@ARR@(991.01),1,3) S MPIRETN="-1^Overwriting the National ICN, "_ICN_", with a local, "_@ARR@(991.01)_", isn't allowed" Q
36 .; quit if ICN has already been assigned to another patient in your data base
37 .S ICN2=@ARR@(991.01)
38 . S DFN2=$O(^DPT("AICN",ICN2,"")) I DFN2'="",'$D(^DPT(DFN2)) K ^DPT("AICN",ICN2)
39 .;^ **41 CHECK IF THE DFN HOLDING THIS ICN IS RELATED TO BOGUS XREF
40 .I $D(^DPT("AICN",ICN2)),DFN'=$O(^DPT("AICN",ICN2,"")) D
41 ..I DFN'=($O(^DPT("AICN",ICN2,""))) D
42 ...N DFN2 S DFN2=$O(^DPT("AICN",ICN2,""))
43 ...D TWODFNS^MPIF002(DFN2,DFN,ICN2)
44 ..I $P($$SITE^VASITE(),"^",3)'=200 S MPIRETN="-1^ICN "_ICN2_" is already in use for pt DFN "_DFN ;;**37
45 .Q:+MPIRETN=-1
46 .K FDA S FDA(1,2,DFN_",",991.01)=@ARR@(991.01)
47 .K MPIERR D FILE^DIE("E","FDA(1)","MPIERR") K FDA(1) I $D(MPIERR("DIERR")) S MPIRETN="-1^Unable to update pt's ICN (DFN="_DFN_") ICN to "_@ARR@(991.01)_" because "_MPIERR("DIERR",1,"TEXT",1)
48 .I +MPIRETN'=0 Q
49 .K FDA S FDA(1,2,DFN_",",991.02)=@ARR@(991.02)
50 .K MPIERR D FILE^DIE("E","FDA(1)","MPIERR") K FDA(1) I $D(MPIERR("DIERR")) S MPIRETN="-1^Unable to update pt's ("_DFN_") ICN Checksum to "_@ARR@(991.02)_" because "_MPIERR("DIERR",1,"TEXT",1)
51 .I +MPIRETN'=0 Q
52 .K FDA S FDA(1,2,DFN_",",991.04)="@"
53 .K MPIERR D FILE^DIE("E","FDA(1)","MPIERR") K FDA(1) I $D(MPIERR("DIERR")) S MPIRETN="-1^Unable to delete pt's ("_DFN_" LOCALLY ASSIGNED ICN field because "_MPIERR("DIERR",1,"TEXT",1)
54 I MPIRETN=0 I $D(@ARR@(991.03)) D
55 .I @ARR@(991.03)="@" K FDA S FDA(1,2,DFN_",",991.03)="@"
56 .I @ARR@(991.03)'="@" I @ARR@(991.03)>0 I $$STA^XUAF4(@ARR@(991.03))'="" S FDA(1,2,DFN_",",991.03)="`"_@ARR@(991.03)
57 .D FILE^DIE("E","FDA(1)","MPIERR") I $D(MPIERR("DIERR")) D
58 ..S MPIRETN="-1^Unable to update pt's ("_DFN_") CMOR to "_@ARR@(991.03)_" because "_MPIERR("DIERR",1,"TEXT",1)
59 ..I +$G(MPISILNT)=0 N RGLOG D START^RGHLLOG(0) D EXC^RGHLLOG(221,"Unable to update CMOR to "_@ARR@(991.03)_" for DFN="_DFN,DFN) D STOP^RGHLLOG(0)
60 I MPIRETN=0 I $D(@ARR@(991.05)) D
61 .I @ARR@(991.05)="@" D
62 ..S SCN=$$SUBNUM^MPIFAPI(DFN),DA=SCN,DIK="^HLS(774," D ^DIK K DIK,DA ;**37
63 ..S $P(^DPT(DFN,"MPI"),"^",5)=""
64 ..K ^DPT("ASCN2",SCN,DFN)
65 .I @ARR@(991.05)'="@" D
66 ..;do edit and return result
67 ..S DIE="^DPT(",DA=DFN,DR="991.05///^S X=@ARR@(991.05)" D ^DIE
68 I MPIRETN=0 I $D(@ARR@(992)) D
69 .;delete old value from history multiple
70 .S MPIX=0 F S MPIX=$O(^DPT(DFN,"MPIFHIS",MPIX)) Q:'MPIX S VALUE=^DPT(DFN,"MPIFHIS",MPIX,0) I $P(VALUE,"^")=@ARR@(992) D
71 ..K ^DPT("AICN",@ARR@(992),DFN),MPIERR,FDA
72 ..S FDA(1,2.0992,MPIX_","_DFN_",",.01)="@" D FILE^DIE("","FDA(1)","MPIERR")
73 ..I $D(MPIERR("DIERR")) S MPIRETN="-1^Unable to delete pt's ("_DFN_") ICN "_@ARR@(992)_" from ICN HISTORY because "_MPIERR("DIERR",1,"TEXT",1) K MPIERR,FDA
74 I MPIRETN=0 I $D(@ARR@(993)) D
75 .;delete old value from history multiple
76 .S MPIX=0 F S MPIX=$O(^DPT(DFN,"MPICMOR",MPIX)) Q:'MPIX S VALUE=^DPT(DFN,"MPICMOR",MPIX,0) I $P(VALUE,"^")=@ARR@(993) D
77 ..K FDA,MPIERR S FDA(1,2.0993,MPIX_","_DFN_",",.01)="@" D FILE^DIE("","FDA(1)","MPIERR")
78 ..I $D(MPIERR("DIERR")) S MPIRETN="-1^Unable to delete pt's ("_DFN_") CMOR "_@ARR@(993)_" from CMOR HISTORY because "_MPIERR("DIERR",1,"TEXT",1) K MPIERR,FDA
79 K ^DPT("AMPIMIS",DFN),RGRSICN
80 L -^DPT("MPI",DFN)
81 Q MPIRETN
82 ;
Note: See TracBrowser for help on using the repository browser.