Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLSUB

HLSUB.m

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