source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLSUB.m@ 767

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1HLSUB ;IRMFO-SF/JC - Subscription Registry ;03/24/2004 14:43
2 ;;1.6;HEALTH LEVEL SEVEN;**14,57,58,59,66,83,108**;Oct 13, 1995
3 ; DBIA #2270 Supported APIs:
4 ; $$ACT - Function to return new subscription control number
5 ; GET - Get information about a subscriber.
6 ; UPD - Add a new subscription or update an existing one
7ACT() ;Activate a new subscription
8 ;Returns new file 774 ien (Subscription Control number)
9 ;Returns -1 if error
10 N X,DLAYGO,DIC,DA,DR
11 Q:'$$LOCK774(0) -1
12 S DLAYGO=774,X=$O(^HLS(774,"B"),-1),X=X+1,DIC=774,DIC(0)="L" D ^DIC
13 L -^HLS(774,0)
14 Q +Y
15LOCK774(IEN) ;
16 N I
17 S I=0
18TRY L +^HLS(774,IEN):1 I '$T S I=I+1 Q:I>600 0 G TRY
19 Q 1
20UPD(HLSCN,HLNN,HLTP,HLAD,HLTD,HLRAP,HLER,HLAPP,HLDESC) ;Subscription update
21 ;HLSCN - Subscription Control number (IEN in file 774), required
22 ;HLNN - Network node (Logical Link IEN or name in file 870), required
23 ;HLTP - Subscription type
24 ; 0 descriptive updates only (default)
25 ; 1 activates clinical updates
26 ; 2 other (locally defined)
27 ;HLTD - Termination date/time (external format), optional.
28 ; If date is supplied, but time isn't, default time is 1 minute
29 ; past midnight.
30 ; For a new subscription,
31 ; - if HLTD is null or not supplied, it means it's open-ended.
32 ; (default)
33 ; For an existing subscription,
34 ; - if HLTD is null or not supplied, no change is made to
35 ; existing TD. (default)
36 ; - the existing TD is deleted if
37 ; 1. HLTD="@" or
38 ; 2. HLTD='""' This is NOT the null string! It is 2 double
39 ; quotes. The variable HL("Q")="""""" is 2 double quotes.
40 ;HLAD - Activation date AND time (external format), optional,
41 ; default 'now'
42 ;HLRAP - Receiving Application (IEN or name in file 771), optional
43 ;HLER - (output) Error message array passed by reference
44 ;HLAPP - Optional, application that created the subscription record.
45 ; 1-40 characters. Excess is truncated.
46 ;HLDESC - Optional, description/documentation, ie, file and record that
47 ; points to this subscription. 1-75 characters. Excess is
48 ; truncated.
49 ;Modification of existing entry triggers archive of previous record.
50 D CHKPARM Q:$D(HLER)
51 Q:'$$LOCK774(HLSCN)
52 D ADDUP
53 L -^HLS(774,HLSCN)
54 Q
55ADDUP ;Lookup and add subscriber (logical link)
56 N HLCD,DIC,DIE,DA,DR,X,Y,HLINKIEN,HLINK0
57 I $G(HLAPP)]"" S $P(^HLS(774,HLSCN,0),U,2)=$E(HLAPP,1,40)
58 I $G(HLDESC)]"" S ^HLS(774,HLSCN,1)=$E(HLDESC,1,75)
59 S HLCD=$$FMTE^XLFDT($$NOW^XLFDT) ;Creation date
60 I $G(HLAD)="" S HLAD=HLCD ;Activation date
61 S DLAYGO=774
62 S DA(1)=HLSCN,DIC="^HLS(774,DA(1),""TO"",",DIC("P")=$P(^DD(774,1,0),U,2)
63 S X=$G(HLRAP)_"@"_HLNN
64 S DIC(0)="LMZ" D ^DIC Q:Y<1
65 S HLINKIEN=+Y,HLINK0=Y(0)
66 K DIC,DIE,DA,DR,X,Y
67 ;If Updating existing record-archive old record
68 I $P(HLINK0,U,2)]"" D ARCHIVE(HLSCN,HLINKIEN,HLINK0)
69 ;bring in update
70 S DA(1)=HLSCN,DA=HLINKIEN,DIE="^HLS(774,DA(1),"_"""TO"""_","
71 S DR="3///^S X=HLNN;4///^S X=HLTP;5///^S X=HLCD;6///^S X=HLAD"
72 I $G(HLRAP)]"" S DR=DR_";1///^S X=HLRAP"
73 I $G(HLTD)=$G(HL("Q"),"""""")!($G(HLTD)="@") D
74 . I $P(HLINK0,U,8)]"" S DR=DR_";7///@" ; remove termination date
75 E I $G(HLTD)]"" D
76 . S DR=DR_";7///"_HLTD_$S(HLTD["@":"",1:"@0001") ; change it
77 D ^DIE
78 Q
79CHKPARM ;
80 K HLER
81 I $G(HLSCN)="" S HLER(1)="Missing subscription control number."
82 I $G(HLNN)="" S HLER(2)="Missing logical link."
83 Q:$D(HLER)
84 S HLTP=+$G(HLTP)
85 I '$D(^HLS(774,HLSCN)) S HLER(4)="Invalid Subscription Control number"
86 I HLNN?1N.N S HLNN=$P($G(^HLCS(870,HLNN,0)),U) I HLNN="" S HLER(5)="Invalid Logical Link" Q
87 I '$O(^HLCS(870,"B",HLNN,0)) S HLER(5)="Invalid logical link" Q
88 I $G(HLRAP)?1N.N S HLRAP=$P($G(^HL(771,HLRAP,0)),U) I $G(HLRAP)="" S HLER(6)="Invalid receiving application." Q
89 ;
90 ; patch HL*1.6*108 start
91 ;I $G(HLRAP)]"",'$O(^HL(771,"B",HLRAP,0)) S HLER(6)="Invalid receiving application."
92 I $G(HLRAP)]"",'$O(^HL(771,"B",$E(HLRAP,1,30),0)) S HLER(6)="Invalid receiving application."
93 ; patch HL*1.6*108 end
94 ;
95 Q
96ARCHIVE(HLSCN,HLINKIEN,HLINK0) ;
97 N DLAYGO,DIC,DIE,DA,DR,X,Y,CD,AD,TD
98 S CD=$P(HLINK0,U,6),AD=$P(HLINK0,U,7),TD=$P(HLINK0,U,8)
99 S CD=$$FMTE^XLFDT(CD),AD=$$FMTE^XLFDT(AD) I TD]"" S TD=$$FMTE^XLFDT(TD)
100 S DA(2)=HLSCN,DA(1)=HLINKIEN,X=$$FMTE^XLFDT($$NOW^XLFDT)
101 S DIC="^HLS(774,DA(2),""TO"",DA(1),""HX"","
102 S DIC("DR")="1///^S X=CD;2///^S X=AD;4///^S X=$P(HLINK0,U,5)"
103 I TD]"" S DIC("DR")=DIC("DR")_";3///^S X=TD"
104 S DLAYGO=774,DIC(0)="L",DIC("P")=$P(^DD(774.01,8,0),U,2)
105 D ^DIC
106 Q
107GET(HLSCN,HLTP,HLCL,HLL) ;Return active subscribers
108 ;Called by a HL7 ROUTING protocol to return array of subscribers
109 ;Make separate call for each 'type' specified EXCEPT TYPE 0
110 ;type 0 returns both '0' and '1' subscribers
111 ;HLSCN=SUBSCRIPTION CONTROL NUMBER
112 ;HLTP=SUBSCRIBER TYPE (0,1,2)/Null=all
113 ;HLCL=HL7 CLIENT PROTOCOL
114 ;HLL=HLL("LINKS",x)=CLIENT PROTOCOL^LOGICAL LINK (passed by reference)
115 ;If the client protocol is not passed in, piece three will be checked
116 ;for a complete destination reference. The destination is of the format
117 ;RECEIVING APPLICATION@LOGICAL LINK. When a valid destination is present
118 ;it will be used for populating the message header and routing.
119 ;The HLL("LINKS") array is required by the HL7 package for routing.
120 N I,J,HLINK,HLND,HLDT,HLINKP,HLINKX,DIC,X,Y
121 Q:'$G(HLSCN)
122 Q:'$G(^HLS(774,HLSCN,0))
123 S HLCL=$G(HLCL)
124 I HLCL]"" S DIC=101,DIC(0)="X",X=HLCL D ^DIC Q:+Y<1
125 S X="",HLTP=$G(HLTP)
126 I $D(HLL("LINKS")) S X=$O(HLL("LINKS",X),-1)
127 S HLDT=$$NOW^XLFDT
128 S I=0
129 F S I=$O(^HLS(774,HLSCN,"TO",I)) Q:'I S J=$G(^(I,0)) D
130 . I HLTP'="",HLTP'=0 Q:$P(J,U,5)'=HLTP ;type specified
131 . I HLTP=0 Q:$P(J,U,5)>1 ;return clinical and descriptive
132 . Q:$P(J,U,7)>HLDT ;Activation date is later
133 . I $P(J,U,8)]"" Q:$P(J,U,8)<HLDT ;Subscription terminated
134 . S (HLINKX,HLINKP)=$P(J,U,4)
135 . I HLINKP S HLINKX=$P(^HLCS(870,HLINKP,0),U)
136 . S X=X+1,HLL("LINKS",X)=HLCL_U_HLINKX_U_J
137 Q
Note: See TracBrowser for help on using the repository browser.