HLUCM003 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23/01 12:01
;;1.6;HEALTH LEVEL SEVEN;**88,103**;Oct 13, 1995
;
ADJTIME ; Adjust ^TMP times on basis of unit...
N IENPAR
S IENPAR=0
F S IENPAR=$O(^TMP($J,"HLPARENT",IENPAR)) Q:'IENPAR D
. D ADJPAR(+IENPAR)
Q
;
ADJPAR(IENPAR) ; Adjust times for one unit...
N BEG,DATA,END,IEN772,NUM,PREVTM,TIME
;
S NUM=0,IEN772=0
F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q:'IEN772 D
. S NUM=NUM+1
;
; No adjustments necessary if only one message...
QUIT:NUM'>1 ;->
;
; Find all times...
S IEN772=0
F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q:IEN772'>0 D
. S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2,999) QUIT:DATA']"" ;->
. S X=$P(DATA,U,4) I X?7N.E S TIME(X)=""
. S X=$P(DATA,U,5) I X?7N.E S TIME(X)=""
;
S BEG=$O(TIME(0)),END=$O(TIME(":"),-1)
;
; Set 1st time and last time...
S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,0)) Q:IEN772'>0 ;->
D CORRECT(+IENPAR,+IEN772,4,BEG)
S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,":"),-1) QUIT:IEN772'>0 ;->
D CORRECT(+IENPAR,+IEN772,5,END)
;
; Make other corrections...
S IEN772=0,PREVTM=""
F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q:IEN772'>0 D
. S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2,999) QUIT:DATA']"" ;->
. S TIME(1)=$P(DATA,U,4),TIME(2)=$P(DATA,U,5)
.
. ; If first time thru...
. I PREVTM="" D QUIT ;->
. . I TIME(1)=TIME(2) S PREVTM=TIME(2) QUIT ;->
. . ; Set 1st entry's time to START=START (0 seconds)
. . D CORRECT(+IENPAR,+IEN772,5,TIME(1))
. . S PREVTM=TIME(1)
.
. I TIME(1)'=PREVTM D
. . D CORRECT(+IENPAR,+IEN772,4,PREVTM)
. . S TIME(1)=PREVTM
.
. I TIME(1)>TIME(2) D
. . D CORRECT(+IENPAR,+IEN772,5,TIME(1))
. . S TIME(2)=TIME(1)
.
. S PREVTM=TIME(2)
.
Q
;
CORRECT(PAR,CHLDIEN,PCE,NEW) ; Change CHILD data...
N BEG,CHILD,DIFF,END,SEC,STORE
;
; Get CHILD and quit if no changes...
S HLCHILD=$G(^TMP($J,"HLCHILD",+CHLDIEN)) QUIT:$P(HLCHILD,U,PCE)=NEW ;->
;
; Put new value into CHILD...
S $P(CHILD,U,PCE)=NEW
;
;Calculate SEC difference and set into CHILD...
S BEG=$P(CHILD,U,4),END=$P(CHILD,U,5)
S DIFF=$$FMDIFF^XLFDT(END,BEG,2)
S $P(CHILD,U,3)=DIFF
;
; Store data...
S ^TMP($J,"HLCHILD",+CHLDIEN)=HLCHILD
;
Q
;
RECNM(PFX,IEN772,FULLNM,REPNM,SRCE) ; Record where name found...
; PFX - [n] for namespace, and [p] for protocol
; IEN772 - IEN of 772
; FULLNM - What is in entry itself, uninferred...
; REPNM - What is to be reported
; SRCE - Where it was inferred from
;
QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;->
;
S REPNM=$G(PFX)_REPNM
;
S ^TMP($J,"HLRECNM")=$G(^TMP($J,"HLRECNM"))+1
S ^TMP($J,"HLRECNM",REPNM)=$G(^TMP($J,"HLRECNM",REPNM))+1
S ^TMP($J,"HLRECNM",REPNM,SRCE)=$G(^TMP($J,"HLRECNM",REPNM,SRCE))+1
S ^TMP($J,"HLRECNM",REPNM,SRCE,IEN772)=FULLNM
;
QUIT
;
MSHMAIL(IEN772) ;
N CT,INOUT,MIEN,NIEN,PCKG,RECNM,TXT,X,XMER,XMPOS,XMRG,XMZ
S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 "" ;->
S INOUT=$P(^HL(772,+IEN772,0),U,4)
S INOUT=$S(INOUT="I":5,1:3)
S CT=0,PCKG="",XMZ=+MIEN,XMER=0
F D QUIT:CT>10!(PCKG]"")!($E(TXT,1,3)="MSH")!(XMER'=0)
. S CT=CT+1
. D REC^XMS3
. S TXT=$G(XMRG) QUIT:$E(TXT,1,3)'="MSH" ;->
. S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT)
. S PCKG=$$PCKGMSH(TXT,INOUT)
. D RECNM("[n]",IEN772,RECNM,PCKG,"MAIL")
QUIT PCKG
;
MSH772(IEN772) ; Get PCKG from MSH segment in 772...
; Call here ONLY if can't get MSH segment from 773...
N CT,IN,INOUT,PCKG,RECNM,TXT,X
S IN=0,CT=0,PCKG=""
S INOUT=$$INOUT(+IEN772)
F S IN=$O(^HL(772,+IEN772,"IN",IN)) Q:IN'>0!(CT>10)!(PCKG]"") D
. S CT=CT+1
. S TXT=$G(^HL(772,+IEN772,"IN",+IN,0)) QUIT:TXT']"" ;->
. QUIT:$E(TXT,1,3)'="MSH" ;->
. S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT)
. S PCKG=$$PCKGMSH(TXT,INOUT)
. D RECNM("[n]",IEN772,RECNM,PCKG,772)
QUIT PCKG
;
MSH773(IEN772) ; Get PCKG from MSH segment in 773...
N IEN773,INOUT,MSH,PCKG,RECNM,X
S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 "" ;->
S INOUT=$$INOUT(IEN772)
S MSH=$G(^HLMA(+IEN773,"MSH",1,0)) QUIT:MSH']"" "" ;->
S X=$E(MSH,4),RECNM=$P(MSH,X,INOUT)
S PCKG=$$PCKGMSH(MSH,INOUT)
I PCKG="VAMC" D
. N NMSP
. S NMSP=PCKG,INOUT=$S(INOUT=5:3,1:3)
. S X=$E(MSH,4),RECNM=$P(MSH,X,INOUT)
. S PCKG=$$PCKGMSH(MSH,INOUT) QUIT:$$PCKGMSH(MSH,INOUT)]"" ;->
. S PCKG=NMSP ; Reset
D RECNM("[n]",IEN772,RECNM,PCKG,773)
QUIT PCKG
;
INOUT(IEN772) ;
N INOUT
S INOUT=$P($G(^HL(772,+IEN772,0)),U,4)
S INOUT=$S(INOUT="I":5,1:3) ; Default to O, which is case in HEC error
QUIT INOUT
;
PCKGMSH(MSH,INOUT) ; Extract PCKG namespace from MSH segment
N DEL,PFROM
S DEL=$E(MSH,4),INOUT=$S($G(INOUT):INOUT,1:3)
S PFROM=$P(MSH,DEL,INOUT) QUIT:PFROM']"" "" ;->
QUIT $$FIXNMSP^HLUCM003(PFROM)
;
ERRCHK ; Error checks...
;
; DATE checks...
S START=+$G(START),END=+$G(END)
I START'?7N&(START'?7N1"."1.N) D ERR^HLUCM("INVALID START TIME")
I END'?7N&(END'?7N1"."1.N) D ERR^HLUCM("INVALID END TIME")
I '$D(ERRINFO("INVALID START TIME")) D
. I '$D(ERRINFO("INVALID END TIME")) D
. . I START=END!(START<END) QUIT ;->
. . D ERR^HLUCM("END TIME PRECEDES START TIME")
;
; If condition=BOTH, can't be ALL(1/2) and ALL(1/2) or
; ALL(1/2) and SPECIFIC. BOTH can only be SPECIFIC and SPECIFIC.
I COND="BOTH" D
. N P1,P2,P3
. S P1=$S($G(PNMSP)>0:1,1:0) ; namespace 0/1
. S P2=$S($G(IEN101)>0:1,1:0) ; protocol 0/1
. S P3=P1+P2 QUIT:P3'>0 ;->
. D ERR^HLUCM("BOTH NAMESPACES(S) AND PROTOCOL(S) MUST BE PASSED SPECIFICALLY")
QUIT
;
SETMORE ; More defaults...
;
; Check format of PNMSP...
; If not passed by reference...
I 'NMSPTYPE D ; Namespace(s) not passed as an array
. ; Passed as 1 or 2 or O^NMSP, but is it valid?
. I '$$OKPAR^HLUCM002(PNMSP) D
. . D ERR^HLUCM("INVALID NAMESPACE PARAMETER")
;
; Check format of IEN101...
; If not passed by reference...
I 'PROTYPE D ; Protocol(s) not passed as an array
. ; Passed as 1 or 2 or 0^PROT or 0^IEN, but is it valid?
. I '$$OKPAR^HLUCM002(IEN101) D ; Check format...
. . D ERR^HLUCM("INVALID PROTOCOL PARAMETER")
. S IEN101=$$OKPAR101^HLUCM001($G(IEN101)) I IEN101']"" D
. . I $D(ERRINFO("INVALID PROTOCOL PARAMETER")) QUIT ;->
. . QUIT:IEN101["0^9999999" ;->
. . D ERR^HLUCM("CAN'T FIND PROTOCOL")
QUIT
;
FIXNMSP(PCKG,I772) ; First space piece, strip _
N APPR,APPS,FACR,FACS,I773,MSH
;
S I772=+$G(I772)
;
; Get 773 (or 772)-related information...
S I773=$O(^HLMA("B",+I772,0))
S MSH=$G(^HLMA(+I773,"MSH",1,0))
I MSH']"" S X=$G(^HL(772,+I772,"IN",1,0)) S:$E(X,1,3)=MSH MSH=X
S X=$E(MSH,4),APPS=$P(MSH,X,3),FACS=$P(MSH,X,4),APPR=$P(MSH,X,5),FACR=$P(MSH,X,6)
;
S PCKG=$$NMSPCHG^HLUCM050(PCKG)
;
QUIT $TR($E($P($P(PCKG," "),"-"),1,4),"_ ","") ;->
;
CTPCKG(PCKG) ; Should entry be counted on basis of package?
; (Might be countable if protocol matches remember.)
; If list of packages passed by reference, is PCKG in array?
; IEN101,NMSPTYPE,PNMSP -- req
N CTPCKG
;
; Must count everything...
I $G(PNMSP)=1!($G(PNMSP)=2) QUIT 1 ;->
;
; If passed namspace by array, is PCKG in array?
I NMSPTYPE=1 QUIT $S($$REFPCKG^HLUCM001(PCKG):1,1:"") ;->
;
; If passed in "0^NAMESPACE" format...
I $$OK0CALL^HLUCM002(PNMSP) D QUIT $S(PCKG]"":1,1:"") ;->
. I $P(PNMSP,U,2)'=PCKG S PCKG=""
;
QUIT ""
;
CTPROT(PROT) ; Should entry be counted on basis of protocol?
; (Might be countable if package matches remember.)
; IEN,PROTYPE -- req
;
N CTPROT
;
; Must count everything...
I $G(IEN101)=1!($G(IEN101)=2) QUIT 1 ;->
;
; If passed protocols by array, is PROT in array?
I PROTYPE=1 QUIT $S($$REFPROT^HLUCM001(PROT):1,1:"") ;->
;
; If PROT not found, and passed 0^PROTNM or 0^PROTIEN,
; can't do anything more...
I $$OK0CALL^HLUCM002(IEN101) D QUIT $S(PROT]"":1,1:"") ;->
. N VAL
. QUIT:PROT']"" ;->
. S VAL=$P(IEN101,U,2)
. I $P(PROT,"~")'=VAL&($P(PROT,"~",2)'=VAL) S PROT=""
;
QUIT ""
;
EOR ; HLUCM003 - HL7/Capacity Mgt API-II ;10/23/01 12:01
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUCM003 8156 printed Sep 23, 2025@19:36:20 Page 2
HLUCM003 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23/01 12:01
+1 ;;1.6;HEALTH LEVEL SEVEN;**88,103**;Oct 13, 1995
+2 ;
ADJTIME ; Adjust ^TMP times on basis of unit...
+1 NEW IENPAR
+2 SET IENPAR=0
+3 FOR
SET IENPAR=$ORDER(^TMP($JOB,"HLPARENT",IENPAR))
if 'IENPAR
QUIT
Begin DoDot:1
+4 DO ADJPAR(+IENPAR)
End DoDot:1
+5 QUIT
+6 ;
ADJPAR(IENPAR) ; Adjust times for one unit...
+1 NEW BEG,DATA,END,IEN772,NUM,PREVTM,TIME
+2 ;
+3 SET NUM=0
SET IEN772=0
+4 FOR
SET IEN772=$ORDER(^TMP($JOB,"HLPARENT",+IENPAR,IEN772))
if 'IEN772
QUIT
Begin DoDot:1
+5 SET NUM=NUM+1
End DoDot:1
+6 ;
+7 ; No adjustments necessary if only one message...
+8 ;->
if NUM'>1
QUIT
+9 ;
+10 ; Find all times...
+11 SET IEN772=0
+12 FOR
SET IEN772=$ORDER(^TMP($JOB,"HLPARENT",+IENPAR,IEN772))
if IEN772'>0
QUIT
Begin DoDot:1
+13 ;->
SET DATA=$PIECE($GET(^TMP($JOB,"HLCHILD",+IEN772)),"~",2,999)
if DATA']""
QUIT
+14 SET X=$PIECE(DATA,U,4)
IF X?7N.E
SET TIME(X)=""
+15 SET X=$PIECE(DATA,U,5)
IF X?7N.E
SET TIME(X)=""
End DoDot:1
+16 ;
+17 SET BEG=$ORDER(TIME(0))
SET END=$ORDER(TIME(":"),-1)
+18 ;
+19 ; Set 1st time and last time...
+20 ;->
SET IEN772=$ORDER(^TMP($JOB,"HLPARENT",+IENPAR,0))
if IEN772'>0
QUIT
+21 DO CORRECT(+IENPAR,+IEN772,4,BEG)
+22 ;->
SET IEN772=$ORDER(^TMP($JOB,"HLPARENT",+IENPAR,":"),-1)
if IEN772'>0
QUIT
+23 DO CORRECT(+IENPAR,+IEN772,5,END)
+24 ;
+25 ; Make other corrections...
+26 SET IEN772=0
SET PREVTM=""
+27 FOR
SET IEN772=$ORDER(^TMP($JOB,"HLPARENT",+IENPAR,IEN772))
if IEN772'>0
QUIT
Begin DoDot:1
+28 ;->
SET DATA=$PIECE($GET(^TMP($JOB,"HLCHILD",+IEN772)),"~",2,999)
if DATA']""
QUIT
+29 SET TIME(1)=$PIECE(DATA,U,4)
SET TIME(2)=$PIECE(DATA,U,5)
+30 +31 ; If first time thru...
+32 ;->
IF PREVTM=""
Begin DoDot:2
+33 ;->
IF TIME(1)=TIME(2)
SET PREVTM=TIME(2)
QUIT
+34 ; Set 1st entry's time to START=START (0 seconds)
+35 DO CORRECT(+IENPAR,+IEN772,5,TIME(1))
+36 SET PREVTM=TIME(1)
End DoDot:2
QUIT
+37 +38 IF TIME(1)'=PREVTM
Begin DoDot:2
+39 DO CORRECT(+IENPAR,+IEN772,4,PREVTM)
+40 SET TIME(1)=PREVTM
End DoDot:2
+41 +42 IF TIME(1)>TIME(2)
Begin DoDot:2
+43 DO CORRECT(+IENPAR,+IEN772,5,TIME(1))
+44 SET TIME(2)=TIME(1)
End DoDot:2
+45 +46 SET PREVTM=TIME(2)
+47 End DoDot:1
+48 QUIT
+49 ;
CORRECT(PAR,CHLDIEN,PCE,NEW) ; Change CHILD data...
+1 NEW BEG,CHILD,DIFF,END,SEC,STORE
+2 ;
+3 ; Get CHILD and quit if no changes...
+4 ;->
SET HLCHILD=$GET(^TMP($JOB,"HLCHILD",+CHLDIEN))
if $PIECE(HLCHILD,U,PCE)=NEW
QUIT
+5 ;
+6 ; Put new value into CHILD...
+7 SET $PIECE(CHILD,U,PCE)=NEW
+8 ;
+9 ;Calculate SEC difference and set into CHILD...
+10 SET BEG=$PIECE(CHILD,U,4)
SET END=$PIECE(CHILD,U,5)
+11 SET DIFF=$$FMDIFF^XLFDT(END,BEG,2)
+12 SET $PIECE(CHILD,U,3)=DIFF
+13 ;
+14 ; Store data...
+15 SET ^TMP($JOB,"HLCHILD",+CHLDIEN)=HLCHILD
+16 ;
+17 QUIT
+18 ;
RECNM(PFX,IEN772,FULLNM,REPNM,SRCE) ; Record where name found...
+1 ; PFX - [n] for namespace, and [p] for protocol
+2 ; IEN772 - IEN of 772
+3 ; FULLNM - What is in entry itself, uninferred...
+4 ; REPNM - What is to be reported
+5 ; SRCE - Where it was inferred from
+6 ;
+7 ;->
if $GET(^TMP($JOB,"HLUCM"))'="DEBUG GLOBAL"
QUIT
+8 ;
+9 SET REPNM=$GET(PFX)_REPNM
+10 ;
+11 SET ^TMP($JOB,"HLRECNM")=$GET(^TMP($JOB,"HLRECNM"))+1
+12 SET ^TMP($JOB,"HLRECNM",REPNM)=$GET(^TMP($JOB,"HLRECNM",REPNM))+1
+13 SET ^TMP($JOB,"HLRECNM",REPNM,SRCE)=$GET(^TMP($JOB,"HLRECNM",REPNM,SRCE))+1
+14 SET ^TMP($JOB,"HLRECNM",REPNM,SRCE,IEN772)=FULLNM
+15 ;
+16 QUIT
+17 ;
MSHMAIL(IEN772) ;
+1 NEW CT,INOUT,MIEN,NIEN,PCKG,RECNM,TXT,X,XMER,XMPOS,XMRG,XMZ
+2 ;->
SET MIEN=$PIECE($GET(^HL(772,+IEN772,0)),U,5)
if MIEN'>0
QUIT ""
+3 SET INOUT=$PIECE(^HL(772,+IEN772,0),U,4)
+4 SET INOUT=$SELECT(INOUT="I":5,1:3)
+5 SET CT=0
SET PCKG=""
SET XMZ=+MIEN
SET XMER=0
+6 FOR
Begin DoDot:1
+7 SET CT=CT+1
+8 DO REC^XMS3
+9 ;->
SET TXT=$GET(XMRG)
if $EXTRACT(TXT,1,3)'="MSH"
QUIT
+10 SET X=$EXTRACT(TXT,4)
SET RECNM=$PIECE(TXT,X,INOUT)
+11 SET PCKG=$$PCKGMSH(TXT,INOUT)
+12 DO RECNM("[n]",IEN772,RECNM,PCKG,"MAIL")
End DoDot:1
if CT>10!(PCKG]"")!($EXTRACT(TXT,1,3)="MSH")!(XMER'=0)
QUIT
+13 QUIT PCKG
+14 ;
MSH772(IEN772) ; Get PCKG from MSH segment in 772...
+1 ; Call here ONLY if can't get MSH segment from 773...
+2 NEW CT,IN,INOUT,PCKG,RECNM,TXT,X
+3 SET IN=0
SET CT=0
SET PCKG=""
+4 SET INOUT=$$INOUT(+IEN772)
+5 FOR
SET IN=$ORDER(^HL(772,+IEN772,"IN",IN))
if IN'>0!(CT>10)!(PCKG]"")
QUIT
Begin DoDot:1
+6 SET CT=CT+1
+7 ;->
SET TXT=$GET(^HL(772,+IEN772,"IN",+IN,0))
if TXT']""
QUIT
+8 ;->
if $EXTRACT(TXT,1,3)'="MSH"
QUIT
+9 SET X=$EXTRACT(TXT,4)
SET RECNM=$PIECE(TXT,X,INOUT)
+10 SET PCKG=$$PCKGMSH(TXT,INOUT)
+11 DO RECNM("[n]",IEN772,RECNM,PCKG,772)
End DoDot:1
+12 QUIT PCKG
+13 ;
MSH773(IEN772) ; Get PCKG from MSH segment in 773...
+1 NEW IEN773,INOUT,MSH,PCKG,RECNM,X
+2 ;->
SET IEN773=$ORDER(^HLMA("B",IEN772,0))
if IEN773'>0
QUIT ""
+3 SET INOUT=$$INOUT(IEN772)
+4 ;->
SET MSH=$GET(^HLMA(+IEN773,"MSH",1,0))
if MSH']""
QUIT ""
+5 SET X=$EXTRACT(MSH,4)
SET RECNM=$PIECE(MSH,X,INOUT)
+6 SET PCKG=$$PCKGMSH(MSH,INOUT)
+7 IF PCKG="VAMC"
Begin DoDot:1
+8 NEW NMSP
+9 SET NMSP=PCKG
SET INOUT=$SELECT(INOUT=5:3,1:3)
+10 SET X=$EXTRACT(MSH,4)
SET RECNM=$PIECE(MSH,X,INOUT)
+11 ;->
SET PCKG=$$PCKGMSH(MSH,INOUT)
if $$PCKGMSH(MSH,INOUT)]""
QUIT
+12 ; Reset
SET PCKG=NMSP
End DoDot:1
+13 DO RECNM("[n]",IEN772,RECNM,PCKG,773)
+14 QUIT PCKG
+15 ;
INOUT(IEN772) ;
+1 NEW INOUT
+2 SET INOUT=$PIECE($GET(^HL(772,+IEN772,0)),U,4)
+3 ; Default to O, which is case in HEC error
SET INOUT=$SELECT(INOUT="I":5,1:3)
+4 QUIT INOUT
+5 ;
PCKGMSH(MSH,INOUT) ; Extract PCKG namespace from MSH segment
+1 NEW DEL,PFROM
+2 SET DEL=$EXTRACT(MSH,4)
SET INOUT=$SELECT($GET(INOUT):INOUT,1:3)
+3 ;->
SET PFROM=$PIECE(MSH,DEL,INOUT)
if PFROM']""
QUIT ""
+4 QUIT $$FIXNMSP^HLUCM003(PFROM)
+5 ;
ERRCHK ; Error checks...
+1 ;
+2 ; DATE checks...
+3 SET START=+$GET(START)
SET END=+$GET(END)
+4 IF START'?7N&(START'?7N1"."1.N)
DO ERR^HLUCM("INVALID START TIME")
+5 IF END'?7N&(END'?7N1"."1.N)
DO ERR^HLUCM("INVALID END TIME")
+6 IF '$DATA(ERRINFO("INVALID START TIME"))
Begin DoDot:1
+7 IF '$DATA(ERRINFO("INVALID END TIME"))
Begin DoDot:2
+8 ;->
IF START=END!(START<END)
QUIT
+9 DO ERR^HLUCM("END TIME PRECEDES START TIME")
End DoDot:2
End DoDot:1
+10 ;
+11 ; If condition=BOTH, can't be ALL(1/2) and ALL(1/2) or
+12 ; ALL(1/2) and SPECIFIC. BOTH can only be SPECIFIC and SPECIFIC.
+13 IF COND="BOTH"
Begin DoDot:1
+14 NEW P1,P2,P3
+15 ; namespace 0/1
SET P1=$SELECT($GET(PNMSP)>0:1,1:0)
+16 ; protocol 0/1
SET P2=$SELECT($GET(IEN101)>0:1,1:0)
+17 ;->
SET P3=P1+P2
if P3'>0
QUIT
+18 DO ERR^HLUCM("BOTH NAMESPACES(S) AND PROTOCOL(S) MUST BE PASSED SPECIFICALLY")
End DoDot:1
+19 QUIT
+20 ;
SETMORE ; More defaults...
+1 ;
+2 ; Check format of PNMSP...
+3 ; If not passed by reference...
+4 ; Namespace(s) not passed as an array
IF 'NMSPTYPE
Begin DoDot:1
+5 ; Passed as 1 or 2 or O^NMSP, but is it valid?
+6 IF '$$OKPAR^HLUCM002(PNMSP)
Begin DoDot:2
+7 DO ERR^HLUCM("INVALID NAMESPACE PARAMETER")
End DoDot:2
End DoDot:1
+8 ;
+9 ; Check format of IEN101...
+10 ; If not passed by reference...
+11 ; Protocol(s) not passed as an array
IF 'PROTYPE
Begin DoDot:1
+12 ; Passed as 1 or 2 or 0^PROT or 0^IEN, but is it valid?
+13 ; Check format...
IF '$$OKPAR^HLUCM002(IEN101)
Begin DoDot:2
+14 DO ERR^HLUCM("INVALID PROTOCOL PARAMETER")
End DoDot:2
+15 SET IEN101=$$OKPAR101^HLUCM001($GET(IEN101))
IF IEN101']""
Begin DoDot:2
+16 ;->
IF $DATA(ERRINFO("INVALID PROTOCOL PARAMETER"))
QUIT
+17 ;->
if IEN101["0^9999999"
QUIT
+18 DO ERR^HLUCM("CAN'T FIND PROTOCOL")
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
FIXNMSP(PCKG,I772) ; First space piece, strip _
+1 NEW APPR,APPS,FACR,FACS,I773,MSH
+2 ;
+3 SET I772=+$GET(I772)
+4 ;
+5 ; Get 773 (or 772)-related information...
+6 SET I773=$ORDER(^HLMA("B",+I772,0))
+7 SET MSH=$GET(^HLMA(+I773,"MSH",1,0))
+8 IF MSH']""
SET X=$GET(^HL(772,+I772,"IN",1,0))
if $EXTRACT(X,1,3)=MSH
SET MSH=X
+9 SET X=$EXTRACT(MSH,4)
SET APPS=$PIECE(MSH,X,3)
SET FACS=$PIECE(MSH,X,4)
SET APPR=$PIECE(MSH,X,5)
SET FACR=$PIECE(MSH,X,6)
+10 ;
+11 SET PCKG=$$NMSPCHG^HLUCM050(PCKG)
+12 ;
+13 ;->
QUIT $TRANSLATE($EXTRACT($PIECE($PIECE(PCKG," "),"-"),1,4),"_ ","")
+14 ;
CTPCKG(PCKG) ; Should entry be counted on basis of package?
+1 ; (Might be countable if protocol matches remember.)
+2 ; If list of packages passed by reference, is PCKG in array?
+3 ; IEN101,NMSPTYPE,PNMSP -- req
+4 NEW CTPCKG
+5 ;
+6 ; Must count everything...
+7 ;->
IF $GET(PNMSP)=1!($GET(PNMSP)=2)
QUIT 1
+8 ;
+9 ; If passed namspace by array, is PCKG in array?
+10 ;->
IF NMSPTYPE=1
QUIT $SELECT($$REFPCKG^HLUCM001(PCKG):1,1:"")
+11 ;
+12 ; If passed in "0^NAMESPACE" format...
+13 ;->
IF $$OK0CALL^HLUCM002(PNMSP)
Begin DoDot:1
+14 IF $PIECE(PNMSP,U,2)'=PCKG
SET PCKG=""
End DoDot:1
QUIT $SELECT(PCKG]"":1,1:"")
+15 ;
+16 QUIT ""
+17 ;
CTPROT(PROT) ; Should entry be counted on basis of protocol?
+1 ; (Might be countable if package matches remember.)
+2 ; IEN,PROTYPE -- req
+3 ;
+4 NEW CTPROT
+5 ;
+6 ; Must count everything...
+7 ;->
IF $GET(IEN101)=1!($GET(IEN101)=2)
QUIT 1
+8 ;
+9 ; If passed protocols by array, is PROT in array?
+10 ;->
IF PROTYPE=1
QUIT $SELECT($$REFPROT^HLUCM001(PROT):1,1:"")
+11 ;
+12 ; If PROT not found, and passed 0^PROTNM or 0^PROTIEN,
+13 ; can't do anything more...
+14 ;->
IF $$OK0CALL^HLUCM002(IEN101)
Begin DoDot:1
+15 NEW VAL
+16 ;->
if PROT']""
QUIT
+17 SET VAL=$PIECE(IEN101,U,2)
+18 IF $PIECE(PROT,"~")'=VAL&($PIECE(PROT,"~",2)'=VAL)
SET PROT=""
End DoDot:1
QUIT $SELECT(PROT]"":1,1:"")
+19 ;
+20 QUIT ""
+21 ;
EOR ; HLUCM003 - HL7/Capacity Mgt API-II ;10/23/01 12:01
