- 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 Jan 18, 2025@03:01:05 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