source: WorldVistAEHR/trunk/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFA37.m@ 699

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1MPIFA37 ;BIR/DLR-Utility for processing an ADT-A37 Un-link ID ;DEC 11, 2001
2 ;;1.0; MASTER PATIENT INDEX VISTA ;**22**;30 Apr 99
3DBIA ; Supported IA's
4 ;
5 ;IA: 2796 - EXC, START, and STOP^RGHLLOG
6 ;IA: 2988 - $$DELALLTF and $$DELETETF^VAFCTFU
7 ;
8IN ;Entry point for processing ADT-A37 - unlink patient information
9 ;Called from the MPIF ADT-A37 CLIENT protocol processing routine
10 ;There are no inputs or outputs
11 ;
12 N MPIF,STATN,MPIFI,MSG,SG,MPIFARR,PDFN,INST,MFUPT,PDLT,TFIEN,ICNAUTH,MPISITE
13 N ICN,HLCOMP,CNT,X,MPIFERR,MPIFX,MPIDFN,MPISSN,ERROR,DFN,NODE,CMOR2,PID
14 S MPISSN="",MPIDFN="",ICN="",ERROR=""
15INIT ;Process in the Treating Facility MFN msg
16 F MPIFI=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,MPIF(MPIFI))=HLNODE,SG=$E(HLNODE,1,3) D:SG?2A1(1A,1N) PICK
17 ;replace/remove/unlink the mismatched ICN in PID(2) as well as the old CMOR from the patients record
18 S CMOR2="",DFN=$$GETDFN^MPIF001(+PID(2)) I +DFN>0 S NODE=$$MPINODE^MPIFAPI(DFN) I NODE'="" S CMOR2=$P(NODE,"^",3)
19 ;if assigning authority = site station# then remove the ICN from site
20 I $P(PID(2),"^",2)=$P($$SITE^VASITE,"^",3) D REPLACE("@","",PID(2),CMOR2,.ERROR)
21 ;if assigning authority '= site station# then remove assigning authority from TF list for the given ICN
22 I $P(PID(2),"^",2)'=$P($$SITE^VASITE,"^",3) S MPISITE=$$IEN^XUAF4($P(PID(2),"^",2)) D
23 . I $P(PID(2),"^",2)'>0 S ERROR="-1^Unable to remove station#"_$P(PID(2),"^",2)_" from TF list" Q
24 . I +$P(PID(2),"^",2)>0 S ERROR=$$DELETETF^VAFCTFU(ICN,MPISITE)
25 S ERROR=$S(+ERROR=0:"",1:$P(ERROR,"^",2))
26 ;create response message
27 S CNT=1
28 S HLA("HLA",1)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_$G(ERROR) S CNT=CNT+1
29 ;Send back the appl. ack (ACK) with the ADT-A37 transaction status
30 D ROUTE
31 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MPIFERR,"",.HLP)
32 Q
33PICK ;check routine for segment entry point
34 I $T(@SG)]"" D @SG
35 I $T(@SG)="" Q
36 Q
37MSH ;;MSH
38 ;process the MSH segment
39 S (HLFS,HL("FS"))=$E(MSG,4),(HLECH,HL("ECH"))=$E(MSG,5,8)
40 S HLCOMP=$E(HL("ECH"),1)
41 S MPIFARR("SENDING SITE")=$P(MSG,HL("FS"),4)
42 Q
43EVN ;;EVN
44 ;process the EVN segment
45 S STATN=+$$SITE^VASITE()_"^"_$$FMDATE^HLFNC($P(MSG,HL("FS"),3))
46 Q
47PID ;;PID
48 ;process the PID segment
49 N ARRAY,MPIJ
50 D PIDP^RGADTP1(.MSG,.ARRAY,.HL)
51 S MPIJ=$P(MSG,HL("FS"),2)
52 S MPISSN=$G(ARRAY("SSN")),MPIDFN=$G(ARRAY("DFN")),ICN=$G(ARRAY("ICN"))
53 S PID(MPIJ)=+ICN_"^"_$G(ARRAY("MPISSITE"))
54 Q
55RESP ;response process logic entry point
56 Q
57ROUTE ;routing logic entry point
58 N MPI S MPI=$$MPILINK^MPIFAPI() D
59 .I $P($G(MPI),U)'=-1 S HLL("LINKS",1)="MPIF ADT-A37 CLIENT"_"^"_MPI
60 .I $P($G(MPI),U)=-1 D
61 .. N RGLOG D START^RGHLLOG(HLMTIEN,"","")
62 .. D EXC^RGHLLOG(224,"Unable to send ADT-A37 for DFN"_$G(DFN)_" : No MPI link identified",$G(PDFN))
63 .. D STOP^RGHLLOG(0)
64 Q
65REPLACE(ICN1,CMOR1,ICN2,CMOR2,ERROR) ;
66 ;replace icn1 with icn2 and cmor1 with cmor2
67 N MPIARR
68 S ERROR=0
69 I $G(ICN2)'="" S DFN=$$GETDFN^MPIF001(+ICN2) I +DFN'>0 S ERROR="-1^Unable to break ICN "_+ICN2_" because that ICN is unknown"
70 Q:+$G(ERROR)=-1
71 S MPIARR(991.01)="@",MPIARR(991.02)="@",MPIARR(991.03)="@",MPIARR(991.05)="@",MPIARR(992)=$P(ICN2,"V"),MPIARR(993)=CMOR2
72 S ERROR=$$DELALLTF^VAFCTFU(+ICN2)
73 S ERROR=$$UPDATE^MPIFAPI(DFN,"MPIARR",1)
74 Q
Note: See TracBrowser for help on using the repository browser.