138 lines
5.8 KiB
Mathematica
138 lines
5.8 KiB
Mathematica
HLSUB ;IRMFO-SF/JC - Subscription Registry ;03/24/2004 14:43
|
|
;;1.6;HEALTH LEVEL SEVEN;**14,57,58,59,66,83,108**;Oct 13, 1995
|
|
; DBIA #2270 Supported APIs:
|
|
; $$ACT - Function to return new subscription control number
|
|
; GET - Get information about a subscriber.
|
|
; UPD - Add a new subscription or update an existing one
|
|
ACT() ;Activate a new subscription
|
|
;Returns new file 774 ien (Subscription Control number)
|
|
;Returns -1 if error
|
|
N X,DLAYGO,DIC,DA,DR
|
|
Q:'$$LOCK774(0) -1
|
|
S DLAYGO=774,X=$O(^HLS(774,"B"),-1),X=X+1,DIC=774,DIC(0)="L" D ^DIC
|
|
L -^HLS(774,0)
|
|
Q +Y
|
|
LOCK774(IEN) ;
|
|
N I
|
|
S I=0
|
|
TRY L +^HLS(774,IEN):1 I '$T S I=I+1 Q:I>600 0 G TRY
|
|
Q 1
|
|
UPD(HLSCN,HLNN,HLTP,HLAD,HLTD,HLRAP,HLER,HLAPP,HLDESC) ;Subscription update
|
|
;HLSCN - Subscription Control number (IEN in file 774), required
|
|
;HLNN - Network node (Logical Link IEN or name in file 870), required
|
|
;HLTP - Subscription type
|
|
; 0 descriptive updates only (default)
|
|
; 1 activates clinical updates
|
|
; 2 other (locally defined)
|
|
;HLTD - Termination date/time (external format), optional.
|
|
; If date is supplied, but time isn't, default time is 1 minute
|
|
; past midnight.
|
|
; For a new subscription,
|
|
; - if HLTD is null or not supplied, it means it's open-ended.
|
|
; (default)
|
|
; For an existing subscription,
|
|
; - if HLTD is null or not supplied, no change is made to
|
|
; existing TD. (default)
|
|
; - the existing TD is deleted if
|
|
; 1. HLTD="@" or
|
|
; 2. HLTD='""' This is NOT the null string! It is 2 double
|
|
; quotes. The variable HL("Q")="""""" is 2 double quotes.
|
|
;HLAD - Activation date AND time (external format), optional,
|
|
; default 'now'
|
|
;HLRAP - Receiving Application (IEN or name in file 771), optional
|
|
;HLER - (output) Error message array passed by reference
|
|
;HLAPP - Optional, application that created the subscription record.
|
|
; 1-40 characters. Excess is truncated.
|
|
;HLDESC - Optional, description/documentation, ie, file and record that
|
|
; points to this subscription. 1-75 characters. Excess is
|
|
; truncated.
|
|
;Modification of existing entry triggers archive of previous record.
|
|
D CHKPARM Q:$D(HLER)
|
|
Q:'$$LOCK774(HLSCN)
|
|
D ADDUP
|
|
L -^HLS(774,HLSCN)
|
|
Q
|
|
ADDUP ;Lookup and add subscriber (logical link)
|
|
N HLCD,DIC,DIE,DA,DR,X,Y,HLINKIEN,HLINK0
|
|
I $G(HLAPP)]"" S $P(^HLS(774,HLSCN,0),U,2)=$E(HLAPP,1,40)
|
|
I $G(HLDESC)]"" S ^HLS(774,HLSCN,1)=$E(HLDESC,1,75)
|
|
S HLCD=$$FMTE^XLFDT($$NOW^XLFDT) ;Creation date
|
|
I $G(HLAD)="" S HLAD=HLCD ;Activation date
|
|
S DLAYGO=774
|
|
S DA(1)=HLSCN,DIC="^HLS(774,DA(1),""TO"",",DIC("P")=$P(^DD(774,1,0),U,2)
|
|
S X=$G(HLRAP)_"@"_HLNN
|
|
S DIC(0)="LMZ" D ^DIC Q:Y<1
|
|
S HLINKIEN=+Y,HLINK0=Y(0)
|
|
K DIC,DIE,DA,DR,X,Y
|
|
;If Updating existing record-archive old record
|
|
I $P(HLINK0,U,2)]"" D ARCHIVE(HLSCN,HLINKIEN,HLINK0)
|
|
;bring in update
|
|
S DA(1)=HLSCN,DA=HLINKIEN,DIE="^HLS(774,DA(1),"_"""TO"""_","
|
|
S DR="3///^S X=HLNN;4///^S X=HLTP;5///^S X=HLCD;6///^S X=HLAD"
|
|
I $G(HLRAP)]"" S DR=DR_";1///^S X=HLRAP"
|
|
I $G(HLTD)=$G(HL("Q"),"""""")!($G(HLTD)="@") D
|
|
. I $P(HLINK0,U,8)]"" S DR=DR_";7///@" ; remove termination date
|
|
E I $G(HLTD)]"" D
|
|
. S DR=DR_";7///"_HLTD_$S(HLTD["@":"",1:"@0001") ; change it
|
|
D ^DIE
|
|
Q
|
|
CHKPARM ;
|
|
K HLER
|
|
I $G(HLSCN)="" S HLER(1)="Missing subscription control number."
|
|
I $G(HLNN)="" S HLER(2)="Missing logical link."
|
|
Q:$D(HLER)
|
|
S HLTP=+$G(HLTP)
|
|
I '$D(^HLS(774,HLSCN)) S HLER(4)="Invalid Subscription Control number"
|
|
I HLNN?1N.N S HLNN=$P($G(^HLCS(870,HLNN,0)),U) I HLNN="" S HLER(5)="Invalid Logical Link" Q
|
|
I '$O(^HLCS(870,"B",HLNN,0)) S HLER(5)="Invalid logical link" Q
|
|
I $G(HLRAP)?1N.N S HLRAP=$P($G(^HL(771,HLRAP,0)),U) I $G(HLRAP)="" S HLER(6)="Invalid receiving application." Q
|
|
;
|
|
; patch HL*1.6*108 start
|
|
;I $G(HLRAP)]"",'$O(^HL(771,"B",HLRAP,0)) S HLER(6)="Invalid receiving application."
|
|
I $G(HLRAP)]"",'$O(^HL(771,"B",$E(HLRAP,1,30),0)) S HLER(6)="Invalid receiving application."
|
|
; patch HL*1.6*108 end
|
|
;
|
|
Q
|
|
ARCHIVE(HLSCN,HLINKIEN,HLINK0) ;
|
|
N DLAYGO,DIC,DIE,DA,DR,X,Y,CD,AD,TD
|
|
S CD=$P(HLINK0,U,6),AD=$P(HLINK0,U,7),TD=$P(HLINK0,U,8)
|
|
S CD=$$FMTE^XLFDT(CD),AD=$$FMTE^XLFDT(AD) I TD]"" S TD=$$FMTE^XLFDT(TD)
|
|
S DA(2)=HLSCN,DA(1)=HLINKIEN,X=$$FMTE^XLFDT($$NOW^XLFDT)
|
|
S DIC="^HLS(774,DA(2),""TO"",DA(1),""HX"","
|
|
S DIC("DR")="1///^S X=CD;2///^S X=AD;4///^S X=$P(HLINK0,U,5)"
|
|
I TD]"" S DIC("DR")=DIC("DR")_";3///^S X=TD"
|
|
S DLAYGO=774,DIC(0)="L",DIC("P")=$P(^DD(774.01,8,0),U,2)
|
|
D ^DIC
|
|
Q
|
|
GET(HLSCN,HLTP,HLCL,HLL) ;Return active subscribers
|
|
;Called by a HL7 ROUTING protocol to return array of subscribers
|
|
;Make separate call for each 'type' specified EXCEPT TYPE 0
|
|
;type 0 returns both '0' and '1' subscribers
|
|
;HLSCN=SUBSCRIPTION CONTROL NUMBER
|
|
;HLTP=SUBSCRIBER TYPE (0,1,2)/Null=all
|
|
;HLCL=HL7 CLIENT PROTOCOL
|
|
;HLL=HLL("LINKS",x)=CLIENT PROTOCOL^LOGICAL LINK (passed by reference)
|
|
;If the client protocol is not passed in, piece three will be checked
|
|
;for a complete destination reference. The destination is of the format
|
|
;RECEIVING APPLICATION@LOGICAL LINK. When a valid destination is present
|
|
;it will be used for populating the message header and routing.
|
|
;The HLL("LINKS") array is required by the HL7 package for routing.
|
|
N I,J,HLINK,HLND,HLDT,HLINKP,HLINKX,DIC,X,Y
|
|
Q:'$G(HLSCN)
|
|
Q:'$G(^HLS(774,HLSCN,0))
|
|
S HLCL=$G(HLCL)
|
|
I HLCL]"" S DIC=101,DIC(0)="X",X=HLCL D ^DIC Q:+Y<1
|
|
S X="",HLTP=$G(HLTP)
|
|
I $D(HLL("LINKS")) S X=$O(HLL("LINKS",X),-1)
|
|
S HLDT=$$NOW^XLFDT
|
|
S I=0
|
|
F S I=$O(^HLS(774,HLSCN,"TO",I)) Q:'I S J=$G(^(I,0)) D
|
|
. I HLTP'="",HLTP'=0 Q:$P(J,U,5)'=HLTP ;type specified
|
|
. I HLTP=0 Q:$P(J,U,5)>1 ;return clinical and descriptive
|
|
. Q:$P(J,U,7)>HLDT ;Activation date is later
|
|
. I $P(J,U,8)]"" Q:$P(J,U,8)<HLDT ;Subscription terminated
|
|
. S (HLINKX,HLINKP)=$P(J,U,4)
|
|
. I HLINKP S HLINKX=$P(^HLCS(870,HLINKP,0),U)
|
|
. S X=X+1,HLL("LINKS",X)=HLCL_U_HLINKX_U_J
|
|
Q
|