source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCIRN.m@ 813

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

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1HLCIRN ;SFISC/RJH-Don't Purge and Reprocessing message ;07/28/97 10:14
2 ;;1.6;HEALTH LEVEL SEVEN;**33**;Oct 13, 1995
3 Q
4 ;
5DONTPURG() ; set the DONT PURGE field to 1 in order to prevent the message
6 ; from purging.
7 ; return value : 1 for successfully set the field
8 ; -1 for failure
9 ;
10 N FLAG
11 S FLAG=$$SETPURG(1)
12 Q FLAG
13 ;
14TOPURG() ; clear the DONT PURGE field to allow the message to be purged.
15 ; return value : 0 for successfully clear the field
16 ; -1 for failure
17 ;
18 N FLAG
19 S FLAG=$$SETPURG(0)
20 Q FLAG
21 ;
22SETPURG(STATUS) ; to set or to clear the DONT PURGE field
23 ; at least one of the variables, HLMTIEN and HLMTIENS, must be defined
24 ; HLMTIEN- parent message IEN
25 ; HLMTIENS- child message IEN
26 ; input: 1 to set the DONT PURGE field
27 ; 0 to clear the DONT PURGE field.
28 ; return value: 1 means successfully set the DONT PURGE field
29 ; 0 means successfully clear the DONT PURGE field
30 ; -1 means fail to set or to clear the field
31 ;
32 N FLAG
33 S FLAG=""
34 I (STATUS'=1)&(STATUS'=0) Q -1
35 I '$G(HLMTIEN),'$G(HLMTIENS) Q -1
36 ;
37 ; both HLMTIEN and HLMTIENS are defined
38 I $G(HLMTIEN),$G(HLMTIENS) D
39 . I '$D(^HL(772,HLMTIEN)) S FLAG=-1 Q
40 . I '$D(^HL(772,HLMTIENS)) S FLAG=-1 Q
41 . I (HLMTIEN'=$P(^HL(772,HLMTIENS,0),"^",8)) S FLAG=-1 Q
42 . D SETVALUE
43 . S FLAG=STATUS
44 I (FLAG=-1)!(FLAG=STATUS) Q FLAG
45 ;
46 ; only HLMTIEN(parent message IEN) is defined
47 I $G(HLMTIEN) D
48 . I '$D(^HL(772,HLMTIEN)) S FLAG=-1 Q
49 . I (HLMTIEN'=$P(^HL(772,HLMTIEN,0),"^",8)) S FLAG=-1 Q
50 . D SETVALUE
51 . S FLAG=STATUS
52 I (FLAG=-1)!(FLAG=STATUS) Q FLAG
53 ;
54 ; only HLMTIENS(child message IEN) is defined
55 I $G(HLMTIENS) D
56 . I '$D(^HL(772,HLMTIENS)) S FLAG=-1 Q
57 . S HLMTIEN=$P(^HL(772,HLMTIENS,0),"^",8)
58 . I 'HLMTIEN S FLAG=-1 Q
59 . I '$D(^HL(772,HLMTIEN)) S FLAG=-1 Q
60 . I (HLMTIEN'=$P(^HL(772,HLMTIEN,0),"^",8)) S FLAG=-1 Q
61 . D SETVALUE
62 . S FLAG=STATUS
63 Q FLAG
64 ;
65SETVALUE ; set or clear the DONT PURGE field
66 L +^HL(772,HLMTIEN)
67 S ^HL(772,HLMTIEN,2)=STATUS
68 I $G(HLMTIENS) S ^HL(772,HLMTIENS,2)=STATUS
69 L -^HL(772,HLMTIEN)
70 Q
71 ;
72REPROC(IEN,RTN) ; reprocessing message
73 ; IEN- either the parent message IEN or the child message IEN
74 ; RTN- the routine, to be Xecuted for processing the message
75 ; return value: 0 for success, -1 for failure
76 ;
77 N HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT
78 N HL,HDR,FS,ECH,HLMSA,X,X1,X2
79 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
80 S HLMSA=""
81 I '$G(IEN) Q -1
82 I '$D(^HL(772,IEN)) Q -1
83 I $G(RTN)'["" Q -1
84 S HLMTIEN=$P(^HL(772,IEN,0),"^",8)
85 Q:'HLMTIEN -1
86 I HLMTIEN'=IEN S HLMTIENS=IEN
87 ;
88 S X=0
89 F S X=$O(^HL(772,HLMTIEN,"IN",X)) Q:X'>0 D
90 . S X1=$G(^HL(772,HLMTIEN,"IN",X,0))
91 . Q:"FHS,BHS,MSH,MSA"'[$E(X1,1,3)
92 . ; If header segment, process it and set HDR equal to it
93 . I '$D(HDR),"FHS,BHS,MSH"[$E(X1,1,3) D
94 .. S HDR=X1
95 .. S (HL("FS"),FS)=$E(HDR,4)
96 .. S (HL("ECH"),ECH)=$P(HDR,FS,2)
97 .. S $P(HDR,FS,8)=""
98 .. I "FHS,BHS"[$E(HDR,1,3) D
99 ... S HL("DTM")=$P(HDR,FS,7)
100 ... S HL("MID")=$P(HDR,FS,11)
101 ... S X2=$P(HDR,FS,9)
102 ... S HL("PID")=$P(X2,$E(ECH),2)
103 ... S HL("MTN")=$P($P(X2,$E(ECH),3),$E(ECH,4))
104 ... S HL("ETN")=$P($P(X2,$E(ECH),3),$E(ECH,4),2)
105 ... S HL("VER")=$P(X2,$E(ECH),4)
106 ... I $P(HDR,FS,10)]"" S HLMSA="MSA"_FS_$P($P(HDR,FS,10),$E(HDR,5),1)_FS_$P(HDR,FS,12)_FS_$P($P(HDR,FS,10),$E(HDR,5),2)
107 .. I $E(HDR,1,3)="MSH" D
108 ... S HL("DTM")=$P(HDR,FS,7)
109 ... S HL("MID")=$P(HDR,FS,10)
110 ... S HL("PID")=$P(HDR,FS,11)
111 ... S HL("MTN")=$P($P(HDR,FS,9),$E(ECH))
112 ... S HL("ETN")=$P($P(HDR,FS,9),$E(ECH),2)
113 ... S HL("VER")=$P(HDR,FS,12)
114 ... S:$P(HDR,FS,15)]"" HL("ACAT")=$P(HDR,FS,15)
115 ... S:$P(HDR,FS,16)]"" HL("APAT")=$P(HDR,FS,16)
116 ... S:$P(HDR,FS,17)]"" HL("CC")=$P(HDR,FS,17)
117 . ; If acknowledgement segment, set MSA equal to it
118 . I $E(X1,1,3)="MSA",$G(HLMSA)="",$E($G(HDR),1,3)="MSH" S HLMSA=X1
119 Q:'$D(HDR) -1
120 ;
121 I RTN["D " X RTN
122 I RTN'["D " D
123 . I RTN["^" X "D "_RTN
124 . I RTN'["^" X "D ^"_RTN
125 S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_$G(^HL(771.7,9,0))
126 ; update the status of child message
127 I $G(HLMTIENS) D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S($D(HLERR):HLERR,HLRESLT:$P(HLRESLT,"^",2),1:""))
128 ; update the status of parent message
129 D STATUS^HLTF0(HLMTIEN,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,"^",2),1:""))
130 Q 0
Note: See TracBrowser for help on using the repository browser.