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