- 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 Feb 18, 2025@23:26:37 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