source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEHLU.m@ 1732

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

initial load of WorldVistAEHR

File size: 3.5 KB
RevLine 
[613]1IBCNEHLU ;DAOU/ALA - HL7 Utilities ;10-JUN-2002 ; Compiled December 16, 2004 15:36:12
2 ;;2.0;INTEGRATED BILLING;**184,300**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5HLP(PROTOCOL) ; Find the Protocol IEN
6 Q +$O(^ORD(101,"B",PROTOCOL,0))
7 ;
8NAME(NM) ; Convert a name that isn't in standard VISTA format -
9 NEW LNM,FNM,MI
10 ;
11 I NM?." " Q NM
12 ; LastName,FirstName MI
13 I NM["," Q NM
14 ;
15 ; Remove double-spaces from name
16 F Q:$L(NM," ")<2 S NM=$P(NM," ",1)_" "_$P(NM," ",2,9999)
17 ;
18 ; Trim leading/trailing spaces
19 S NM=$$TRIM^XLFSTR(NM)
20 ;
21 ; Find number of spaces in name
22 S II=$L(NM," ")
23 ;
24 I II>3 Q NM
25 I II=3 S FNM=$P(NM," ",1),MI=" "_$P(NM," ",2),LNM=$P(NM," ",3)
26 I II=2 S FNM=$P(NM," ",1),LNM=$P(NM," ",2),MI=""
27 I II<2 Q NM
28 Q LNM_","_FNM_MI
29 ;
30DODCK(DFN,DOD,MGRP,NAME,RIEN,SSN) ; Date of death check
31 ;
32 ; Input Variables
33 ; DFN, DOD, MGRP, NAME, RIEN, SSN
34 ;
35 N CDOD,CIDDSP,IDDSP,IDSSN,MSG,XMSUB
36 S CDOD=$P($G(^DPT(DFN,.35)),U,1),CIDDSP=$$FMTE^XLFDT(CDOD,"5Z")
37 S IDDSP=$$FMTE^XLFDT(DOD,"5Z")
38 S IDSSN=$E(SSN,$L(SSN)-3,$L(SSN))
39 ;
40 ; If the two dates of death are the same, quit
41 I CDOD=DOD G DODCKX
42 ;
43 ; If no current date of death but payer sent one
44 I CDOD="" D G DODCKX
45 . ; Send an email message
46 . S XMSUB="Date of Death Received"
47 . S MSG(1)="A Date of Death ("_IDDSP_") was received for patient: "_NAME_"/"_IDSSN_" "_$$GETDOB^IBCNEDEQ(DFN)_" from"
48 . S MSG(2)="payer "_$$GET1^DIQ(365,RIEN,.03,"E")_". There is no current Date of Death on file for "
49 . S MSG(3)="this patient."
50 . D TXT^IBCNEUT7("MSG")
51 . D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
52 ;
53 S XMSUB="Variant Date of Death"
54 S MSG(1)="A Date of Death ("_IDDSP_") was received for patient: "_NAME_"/"_IDSSN_" "_$$GETDOB^IBCNEDEQ(DFN)_" from payer "_$$GET1^DIQ(365,RIEN,.03,"E")_"."
55 S MSG(2)="This Date of Death does not currently match the Date of Death ("_CIDDSP_") on file for this patient. "
56 D TXT^IBCNEUT7("MSG")
57 D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
58DODCKX ;
59 Q
60 ;
61SPAR ; Segment Parsing
62 ;
63 ; This tag will parse the current segment referenced by the HCT index
64 ; and place the results in the IBSEG array.
65 ;
66 ; Input Variables
67 ; HCT
68 ;
69 ; Output Variables
70 ; IBSEG (ARRAY of fields in segment)
71 ;
72 N II,IJ,IK,IM,IS,ISBEG,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
73 ;
74 ;Reset IBSEG
75 K IBSEG
76 ;
77 S ISCT="",II=0,IS=0
78 F S ISCT=$O(^TMP($J,"IBCNEHLI",HCT,ISCT)) Q:ISCT="" D
79 . S IS=IS+1
80 . S ISDATA(IS)=$G(^TMP($J,"IBCNEHLI",HCT,ISCT))
81 . I $O(^TMP($J,"IBCNEHLI",HCT,ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
82 . S ISPEC(IS)=$L(ISDATA(IS),HLFS)
83 ;
84 S IM=0,LSDATA=""
85LP S IM=IM+1 Q:IM>IS
86 S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
87 F IJ=1:1:NPC-1 D
88 . S II=II+1,IBSEG(II)=$$CLNSTR($P(LSDATA,HLFS,IJ),$E(HL("ECH"),1,2)_$E(HL("ECH"),4),$E(HL("ECH")))
89 S LSDATA=$P(LSDATA,HLFS,NPC)
90 G LP
91CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents in the HL7 seg
92 ;
93 N NUMPEC,PEC,RTSTRING
94 ;
95 S RTSTRING=$$RTRIMCH(STRING,CHARS)
96 ; Now we have string w/o trailing chars, remove from subs
97 S NUMPEC=$L(RTSTRING,SUBSEP)
98 F PEC=1:1:NUMPEC S $P(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($P(RTSTRING,SUBSEP,PEC),CHARS)
99 Q RTSTRING
100 ;
101RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
102 ;
103 N R,L
104 ;
105 S L=1,CHRS=$G(CHRS," ")
106 F R=$L(STR):-1:1 Q:CHRS'[$E(STR,R)
107 I L=R,(CHRS[$E(STR)) S STR=""
108 Q $E(STR,L,R)
109 ;
110 ;
111GTICNM(ICN,NAME) ; Retrieve PID segment and set ICN and patient name
112 ;
113 N HCT,ERFLG,SEG,IBSEG
114 S (HCT,ICN,NAME)="",ERFLG=0
115 F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:ERFLG
116 . D SPAR
117 . S SEG=$G(IBSEG(1)) Q:SEG'="PID"
118 . S ICN=$G(IBSEG(4)),NAME=$G(IBSEG(6)),ERFLG=1
119 Q
Note: See TracBrowser for help on using the repository browser.