HLUCM050 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23/01 12:01
;;1.6;HEALTH LEVEL SEVEN;**103,114**;Oct 13, 1995
;
LOADEM(IEN772,HLNMSP) ; Find all related entries, up to 20...
; HLNMSP is passed by reference...
;
; Note! If entry already loaded, it will not be reloaded.
; (Stored ^TMP($J) data will be used instead.)
;
N ACKTO,CHARC,CHARP,CT,DATA,DATAC,DATAP,DEF,FAC,HL,HLZZI
N HOLDNMSP,I,I772,I773,IEN,IENPAR,LEN,MSGID,MTYPEC
N MTYPEP,NMSP,NMSPP,NUM,PIEN,PROT,PROTP,TIME,TIMEBEG
N TIMEEND,TMDIFF,TMP,TOT772,TOT773,TOTNUM,X,Y
;
KILL HLNMSP
;
; Call already made here?
S IENPAR=+$G(^TMP($J,"HLCHILD",+IEN772)) ; Call already made here?
;
; If call already made, just return results...
I IENPAR D QUIT $P(HLNMSP("HLPARENT",+IENPAR),U,2) ;->
. S HLNMSP("HLPARENT",+IENPAR)=$G(^TMP($J,"HLPARENT",+IENPAR))
. ; HL*1.6*114 added TOTNUM to next 3 lines to avoid ALLOC errors...
. S IEN772=0,TOTNUM=0
. F S IEN772=$O(^TMP($J,"HLPARENT",IENPAR,IEN772)) Q:'IEN772!(TOTNUM>19) D
. . S TOTNUM=TOTNUM+1
. . S HLNMSP("HLPARENT",+IENPAR,IEN772)=$G(^TMP($J,"HLPARENT",IENPAR,IEN772))
. . S HLNMSP("HLCHILD",+IEN772)=$G(^TMP($J,"HLCHILD",+IEN772))
;
S HLNMSP(+IEN772)="" ; Seed for engine...
;
S (NUM,TOTNUM)=1
F D QUIT:NUM'>NUM(1)!(TOTNUM>19)
. S NUM(1)=NUM ; Set NUM(1) = # entries found "now"...
. KILL HOLDNMSP
. S I772=0
. F S I772=$O(HLNMSP(I772)) Q:I772'>0!(TOTNUM>19) D
. . S DATA=$G(^HL(772,+$G(I772),0)) QUIT:DATA']"" ;->
. .
. . ; IEN Search...
. . S HLZZI=0 F S HLZZI=$O(^HL(772,"AF",I772,HLZZI)) Q:'HLZZI!(TOTNUM>19) I HLZZI'=IEN772 D HOLDTOT(HLZZI)
. . ; MSG ID search...
. . S MSGID=$P(DATA,U,6)
. . I MSGID]"" D
. . . S HLZZI=0 F S HLZZI=$O(^HL(772,"C",MSGID,HLZZI)) Q:'HLZZI!(TOTNUM>19) I HLZZI'=IEN772 D HOLDTOT(HLZZI)
. . . D MSGID(MSGID)
. . ; 773 MSG ID search...
. . S I773=+$O(^HLMA("B",I772,0)) I I773 D
. . . S MSGID=$P($G(^HLMA(+I773,0)),U,2) QUIT:MSGID']"" ;->
. . . S I773(1)=0
. . . F S I773(1)=$O(^HLMA("AF",I773,I773(1))) Q:I773(1)'>0!(TOTNUM>19) D
. . . . S X=+$G(^HLMA(+I773(1),0)) I X D HOLDTOT(+X)
. . . S I773(1)=0
. . . F S I773(1)=$O(^HLMA("C",MSGID,I773(1))) Q:I773(1)'>0!(TOTNUM>19) D
. . . . S X=+$G(^HLMA(+I773(1),0)) I X D HOLDTOT(+X)
. . . KILL I773(1)
. . . D MSGID(MSGID)
. .
. . ;
. . ; ACK TO search...
. . I $P(DATA,U,7)>0,$P(DATA,U,7)'=IEN772 D
. . . D HOLDTOT(+$P(DATA,U,7))
. . I I773 D
. . . S ACKTO=$P($G(^HLMA(+I773,0)),U,10) QUIT:ACKTO'>0 ;->
. . . S X=+$G(^HLMA(+ACKTO,0)) I X D HOLDTOT(+X)
. . ;
. . ; HLPARENT search...
. . I $P(DATA,U,8)>0,$P(DATA,U,8)'=IEN772 D
. . . D HOLDTOT(+$P(DATA,U,8))
. . I I773 D
. . . S PIEN=$P($G(^HLMA(+I773,0)),U,6) QUIT:PIEN'>0 ;->
. . . S X=+$G(^HLMA(+PIEN,0)) I X D HOLDTOT(+X)
. .
. . MERGE HLNMSP=HOLDNMSP
. . KILL HOLDNMSP
.
. S I=0,NUM=0 F S I=$O(HLNMSP(I)) Q:'I S NUM=NUM+1
;
I '$$OKALL(.HLNMSP) D QUIT "" ;->
. KILL HLNMSP
;
S FAC=$$FACILITY^HLUCM090(.HLNMSP) I FAC']"" S FAC="UNKNOWN"
S IENPAR=$O(HLNMSP(0))
;
; Find total number characters...
KILL TIMEP
S IEN772=0,CHARC=0,CHARP=0,CT=0,MTYPEP="",NMSPP="",PROTP="",NUM=0
F S IEN772=$O(HLNMSP(IEN772)) Q:'IEN772 D
. S CT=CT+1,NUM=NUM+1
.
. S TMP($J,"HLPARENT",+IENPAR,+IEN772)=$$VAL3(+IEN772,FAC)_U_IENPAR
.
. S CHARC=$$CHAR(+IEN772)
. S DATAC(IEN772)=CHARC
. S CHARP=CHARP+CHARC
.
. S $P(DATAC(IEN772),U,2)=1
.
. S TIME=$$TIME(+IEN772)
. F I=1:1:3 S $P(DATAC(IEN772),U,2+I)=$P(TIME,U,I)
. F I=2,3 S X=$P(TIME,U,I) I X?7N.E S TIMEP(X)=""
.
. S MTYPEC=$$MSGTYPE^HLUCM009(IEN772)
. S $P(DATAC(IEN772),U,6)=MTYPEC
. S MTYPEP=MTYPEP_$S(MTYPEP]"":"~",1:"")_MTYPEC
.
. S PROT=$$PROT101^HLUCM002(+IEN772)
. S $P(DATAC(IEN772),U,7)=PROT
. S:PROT]"" PROTP=PROT
.
. S NMSP=$$NMSPALL(+IEN772)
. S $P(DATAC(IEN772),U,9)=NMSP
. I NMSP]"" D
. . I NMSPP]"",NMSP="XWB",NMSPP'="XWB" QUIT ;->
. . S NMSPP=NMSP
.
. S $P(DATAC(IEN772),U,11)=FAC
;
S TIMEBEG=$O(TIMEP(0)),TIMEEND=$O(TIMEP(":"),-1)
S TMDIFF=$$FMDIFF^XLFDT(TIMEEND,TIMEBEG,2)
;
S DATAP=CHARP_U_CT_U_TMDIFF_U_TIMEBEG_U_TIMEEND_U_MTYPEP_U_PROTP_U_U_NMSPP_U_U_FAC
;
; Set PARENT node...
S IENPAR=$O(HLNMSP(0))
S TMP($J,"HLPARENT",+IENPAR)=DATAP
;
; Set CHILD nodes...
S IEN772=0
F S IEN772=$O(HLNMSP(IEN772)) Q:IEN772'>0 D
. S TMP($J,"HLCHILD",+IEN772)=IENPAR_"~"_$G(DATAC(+IEN772))
;
KILL HLNMSP
MERGE HLNMSP=TMP($J)
MERGE ^TMP($J)=TMP($J)
;
Q NUM
;
OKALL(HLNMSP) ; Does every 772 entry have a valid .01 node?
N FAIL,I772
S FAIL=0,I772=0
F S I772=$O(HLNMSP(I772)) Q:'I772!(FAIL) D
. QUIT:$P($G(^HL(772,+I772,0)),U)?7N1"."1.N ;->
. S FAIL=1
Q 'FAIL
;
VAL3(IEN772,FAC) ; Return sort values...
N TYPEHR,TYPEIO,TYPELR
S TYPEHR=$$TYPETMO^HLUCM002(+IEN772)
S TYPEIO=$$TYPEIO^HLUCM002(+IEN772)
;S TYPELR=$$TYPELR^HLUCM001(+IEN772,FAC)
S TYPELR=$S(FAC["~DNS":"R",1:"L")
Q TYPEHR_U_TYPEIO_U_TYPELR
;
TIME(IEN772) ; Times...
N CT,DATA,IEN773,TMBEG,TMEND,TMDIFF
D TOT772T^HLUCM(+IEN772)
S IEN773=0,CT=0
F S IEN773=$O(^HLMA("B",+IEN772,IEN773)) Q:'IEN773!(CT>20) D
. S CT=CT+1
. D TOT773T^HLUCM(+IEN773)
D TMDIFF^HLUCM
Q DATA("DIFF")_U_DATA("START")_U_DATA("END")
;
;
CHAR(IEN772) ; Number characters...
N CT,DATA,IEN773
D TOT772C^HLUCM(+IEN772)
S IEN773=0,CT=0
F S IEN773=$O(^HLMA("B",+IEN772,IEN773)) Q:'IEN773!(CT>20) D
. S CT=CT+1
. D TOT773C^HLUCM(+IEN773)
Q $G(DATA("CHAR"))
;
GETNMSP(IEN772) ; The one and only place to ask for NAMESPACE...
N HL,NMSP,NUM,PAR,VAL
S NUM=$$LOADEM^HLUCM050(+IEN772,.HL) QUIT:NUM'>0 "" ;->
S PAR=+$G(HL("HLCHILD",+IEN772))
S VAL=$G(HL("HLPARENT",+PAR))
Q $P(VAL,U,9)
;
GETPROT(IEN772) ; One & only place to ask for PROTOCOL...
N HL,NMSP,NUM,PAR,VAL
S NUM=$$LOADEM^HLUCM050(+IEN772,.HL) QUIT:NUM'>0 "" ;->
S PAR=+$G(HL("HLCHILD",+IEN772))
S VAL=$G(HL("HLPARENT",+PAR))
Q $P(VAL,U,7)
;
HOLDTOT(X) D HOLDTOT^HLUCM009(X) QUIT
MSGID(X) D MSGID^HLUCM009(X) QUIT
;
NMSPALL(IEN772) ;Perform all attempts to find NMSP...
N IEN101,IEN94,NMSP
;
; If SPR...
S NMSP=$$SPR(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
;
; Check MSH segment...
S NMSP=$$MSH772^HLUCM003(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
S NMSP=$$MSHMAIL^HLUCM003(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
;
; Get Event Protocol
S IEN101=+$P($G(^HL(772,+IEN772,0)),U,10) QUIT:IEN101'>0 "" ;->
;
; Find XEC routines, and try NMSPXRFs...
S NMSP=$$NMSPXRF(+IEN101) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
;
; Try 9.4 link...
S IEN94=$P($G(^ORD(101,+IEN101,0)),U,12)
I IEN94 S NMSP=$P($$NMSP94(IEN94),U,2) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
;
S NMSP=$$MSH773^HLUCM003(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
;
QUIT ""
;
NMSP94(IEN94) ; From 9.4 find it's namespace...
N D0,DA,DIC,DIQ,DR,NMSP,RET
S RET=$G(^TMP($J,"HLNMSP94",+IEN94)) I RET]"" QUIT RET ;->
S DIC=9.4,DR=".01;1",DA=IEN94,DIQ="NMSP(",DIQ(0)="E"
D EN^DIQ1
S RET=$G(NMSP(9.4,+IEN94,.01,"E"))_U_$G(NMSP(9.4,+IEN94,1,"E"))
S ^TMP($J,"HLNMSP94",+IEN94)=RET
QUIT RET
;
NMSPCHG(NMSP) ; Some miscellaneous special actions first...
N PCKG
;
; Check xref first...
D:'$D(^TMP($J,"HLNMSPXRF")) NMSPXRF^HLUCM009
S PCKG=$$NMSPFROM(NMSP) QUIT:PCKG]"" PCKG ;->
;
S PCKG=NMSP
;
; Other conversions here...
I $E(PCKG,1,2)="DG",PCKG'="DG" S PCKG="DG"
I $E(PCKG,1,3)="VEI",PCKG'="VEIB" S PCKG="VEIB"
I $E(PCKG,1,2)="VA" D
. I PCKG["PIMS" S PCKG="DG" QUIT ;->
. I $G(APPR)["HEC " S PCKG="HEC" QUIT ;->
. I $G(FACR)["HEC " S PCKG="HEC" QUIT ;->
I $E(PCKG,1,2)="LA" S PCKG="LA"
I $E(PCKG,1,2)="VA",PCKG[" PIMS" S PCKG="DG"
I $E(PCKG,1,10)="VAFC ADMIT" S PCKG="DG"
I $E(PCKG,1,8)="VAFC ADT" S PCKG="DG"
I $E(PCKG,1,8)?1"VAFH A"2N S PCKG="DG"
I $E(PCKG,1,15)?1"VAFH CLIENT A"2N S PCKG="DG"
I $E(PCKG,1,2)="XM" S PCKG="XM"
I $E(PCKG,1,2)="XU" S PCKG="XU"
;
QUIT PCKG
;
NMSPXRF(IEN101) ; Find NMSP from ^TMP($J,"NMSPXRF")
N LEN,NMSP,NODE,RTN
I '$D(^TMP($J,"HLNMSPXRF")) D NMSPXRF^HLUCM009 ; Build, if not there
S NMSP=""
F NODE=772,774,771 D QUIT:NMSP]""
. S RTN=$E($P($G(^ORD(101,+IEN101,NODE)),U,2),1,4) QUIT:RTN']"" ;->
. S NMSP=$$NMSPFROM(RTN)
Q NMSP
;
NMSPFROM(TXT) ; From TXT try to find NMSP...
N NMSP
QUIT:$G(TXT)']"" "" ;->
S NMSP=""
F LEN=4:-1:2 D QUIT:NMSP]""
. S NMSP=$G(^TMP($J,"HLNMSPXRF",$E(TXT,1,LEN))) QUIT:NMSP]"" ;->
I NMSP']"" F LEN=4:-1:2 D QUIT:NMSP]""
. ; See Integration Agreement #10048
. N D,DIC,X,Y
. S DIC="^DIC(9.4,",DIC(0)="FO",D="C",X=$E(TXT,1,LEN)
. D MIX^DIC1 QUIT:+Y'>0 ;->
. ; Found! So, set into ^TMP...
. S NMSP=$E(TXT,1,LEN)
. S ^TMP($J,"HLNMSPXRF",NMSP)=NMSP
Q NMSP
;
SPR(IEN772) ; Evaluate SPR segment for RPC for package, possible
; resetting the PCKG variable...
; PCKG -- req
N CHAR,DEL,IN,NMSP
S IN=$G(^HL(772,+IEN772,"IN",1,0))
QUIT:$E(IN,1,4)'="SPR^" "" ;->
QUIT:IN'["REMOTE RPC^" "" ;->
S DEL=$E(IN,4)
S IN=$P(IN,DEL,5) QUIT:IN']"" "" ;->
S IN=$P(IN,"003RPC",2) QUIT:IN']"" "" ;->
S CHAR=+IN,IN=$TR($E(IN,4,CHAR+4),"&","") QUIT:IN']"" "" ;->
I $E(IN,1,2)="IB" QUIT "IB" ;->
I $E(IN,1,2)="OR" QUIT "OR" ;->
I '$D(^TMP($J,"HLNMSPXRF")) D NMSPXRF^HLUCM009
S NMSP=$$NMSPFROM(IN)
QUIT NMSP
;
EOR ; HLUCM050 - HL7/Capacity Mgt API-II ;10/23/01 12:01
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUCM050 9546 printed Dec 13, 2024@02:00:16 Page 2
HLUCM050 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23/01 12:01
+1 ;;1.6;HEALTH LEVEL SEVEN;**103,114**;Oct 13, 1995
+2 ;
LOADEM(IEN772,HLNMSP) ; Find all related entries, up to 20...
+1 ; HLNMSP is passed by reference...
+2 ;
+3 ; Note! If entry already loaded, it will not be reloaded.
+4 ; (Stored ^TMP($J) data will be used instead.)
+5 ;
+6 NEW ACKTO,CHARC,CHARP,CT,DATA,DATAC,DATAP,DEF,FAC,HL,HLZZI
+7 NEW HOLDNMSP,I,I772,I773,IEN,IENPAR,LEN,MSGID,MTYPEC
+8 NEW MTYPEP,NMSP,NMSPP,NUM,PIEN,PROT,PROTP,TIME,TIMEBEG
+9 NEW TIMEEND,TMDIFF,TMP,TOT772,TOT773,TOTNUM,X,Y
+10 ;
+11 KILL HLNMSP
+12 ;
+13 ; Call already made here?
+14 ; Call already made here?
SET IENPAR=+$GET(^TMP($JOB,"HLCHILD",+IEN772))
+15 ;
+16 ; If call already made, just return results...
+17 ;->
IF IENPAR
Begin DoDot:1
+18 SET HLNMSP("HLPARENT",+IENPAR)=$GET(^TMP($JOB,"HLPARENT",+IENPAR))
+19 ; HL*1.6*114 added TOTNUM to next 3 lines to avoid ALLOC errors...
+20 SET IEN772=0
SET TOTNUM=0
+21 FOR
SET IEN772=$ORDER(^TMP($JOB,"HLPARENT",IENPAR,IEN772))
if 'IEN772!(TOTNUM>19)
QUIT
Begin DoDot:2
+22 SET TOTNUM=TOTNUM+1
+23 SET HLNMSP("HLPARENT",+IENPAR,IEN772)=$GET(^TMP($JOB,"HLPARENT",IENPAR,IEN772))
+24 SET HLNMSP("HLCHILD",+IEN772)=$GET(^TMP($JOB,"HLCHILD",+IEN772))
End DoDot:2
End DoDot:1
QUIT $PIECE(HLNMSP("HLPARENT",+IENPAR),U,2)
+25 ;
+26 ; Seed for engine...
SET HLNMSP(+IEN772)=""
+27 ;
+28 SET (NUM,TOTNUM)=1
+29 FOR
Begin DoDot:1
+30 ; Set NUM(1) = # entries found "now"...
SET NUM(1)=NUM
+31 KILL HOLDNMSP
+32 SET I772=0
+33 FOR
SET I772=$ORDER(HLNMSP(I772))
if I772'>0!(TOTNUM>19)
QUIT
Begin DoDot:2
+34 ;->
SET DATA=$GET(^HL(772,+$GET(I772),0))
if DATA']""
QUIT
+35 +36 ; IEN Search...
+37 SET HLZZI=0
FOR
SET HLZZI=$ORDER(^HL(772,"AF",I772,HLZZI))
if 'HLZZI!(TOTNUM>19)
QUIT
IF HLZZI'=IEN772
DO HOLDTOT(HLZZI)
+38 ; MSG ID search...
+39 SET MSGID=$PIECE(DATA,U,6)
+40 IF MSGID]""
Begin DoDot:3
+41 SET HLZZI=0
FOR
SET HLZZI=$ORDER(^HL(772,"C",MSGID,HLZZI))
if 'HLZZI!(TOTNUM>19)
QUIT
IF HLZZI'=IEN772
DO HOLDTOT(HLZZI)
+42 DO MSGID(MSGID)
End DoDot:3
+43 ; 773 MSG ID search...
+44 SET I773=+$ORDER(^HLMA("B",I772,0))
IF I773
Begin DoDot:3
+45 ;->
SET MSGID=$PIECE($GET(^HLMA(+I773,0)),U,2)
if MSGID']""
QUIT
+46 SET I773(1)=0
+47 FOR
SET I773(1)=$ORDER(^HLMA("AF",I773,I773(1)))
if I773(1)'>0!(TOTNUM>19)
QUIT
Begin DoDot:4
+48 SET X=+$GET(^HLMA(+I773(1),0))
IF X
DO HOLDTOT(+X)
End DoDot:4
+49 SET I773(1)=0
+50 FOR
SET I773(1)=$ORDER(^HLMA("C",MSGID,I773(1)))
if I773(1)'>0!(TOTNUM>19)
QUIT
Begin DoDot:4
+51 SET X=+$GET(^HLMA(+I773(1),0))
IF X
DO HOLDTOT(+X)
End DoDot:4
+52 KILL I773(1)
+53 DO MSGID(MSGID)
End DoDot:3
+54 +55 ;
+56 ; ACK TO search...
+57 IF $PIECE(DATA,U,7)>0
IF $PIECE(DATA,U,7)'=IEN772
Begin DoDot:3
+58 DO HOLDTOT(+$PIECE(DATA,U,7))
End DoDot:3
+59 IF I773
Begin DoDot:3
+60 ;->
SET ACKTO=$PIECE($GET(^HLMA(+I773,0)),U,10)
if ACKTO'>0
QUIT
+61 SET X=+$GET(^HLMA(+ACKTO,0))
IF X
DO HOLDTOT(+X)
End DoDot:3
+62 ;
+63 ; HLPARENT search...
+64 IF $PIECE(DATA,U,8)>0
IF $PIECE(DATA,U,8)'=IEN772
Begin DoDot:3
+65 DO HOLDTOT(+$PIECE(DATA,U,8))
End DoDot:3
+66 IF I773
Begin DoDot:3
+67 ;->
SET PIEN=$PIECE($GET(^HLMA(+I773,0)),U,6)
if PIEN'>0
QUIT
+68 SET X=+$GET(^HLMA(+PIEN,0))
IF X
DO HOLDTOT(+X)
End DoDot:3
+69 +70 MERGE HLNMSP=HOLDNMSP
+71 KILL HOLDNMSP
End DoDot:2
+72 +73 SET I=0
SET NUM=0
FOR
SET I=$ORDER(HLNMSP(I))
if 'I
QUIT
SET NUM=NUM+1
End DoDot:1
if NUM'>NUM(1)!(TOTNUM>19)
QUIT
+74 ;
+75 ;->
IF '$$OKALL(.HLNMSP)
Begin DoDot:1
+76 KILL HLNMSP
End DoDot:1
QUIT ""
+77 ;
+78 SET FAC=$$FACILITY^HLUCM090(.HLNMSP)
IF FAC']""
SET FAC="UNKNOWN"
+79 SET IENPAR=$ORDER(HLNMSP(0))
+80 ;
+81 ; Find total number characters...
+82 KILL TIMEP
+83 SET IEN772=0
SET CHARC=0
SET CHARP=0
SET CT=0
SET MTYPEP=""
SET NMSPP=""
SET PROTP=""
SET NUM=0
+84 FOR
SET IEN772=$ORDER(HLNMSP(IEN772))
if 'IEN772
QUIT
Begin DoDot:1
+85 SET CT=CT+1
SET NUM=NUM+1
+86 +87 SET TMP($JOB,"HLPARENT",+IENPAR,+IEN772)=$$VAL3(+IEN772,FAC)_U_IENPAR
+88 +89 SET CHARC=$$CHAR(+IEN772)
+90 SET DATAC(IEN772)=CHARC
+91 SET CHARP=CHARP+CHARC
+92 +93 SET $PIECE(DATAC(IEN772),U,2)=1
+94 +95 SET TIME=$$TIME(+IEN772)
+96 FOR I=1:1:3
SET $PIECE(DATAC(IEN772),U,2+I)=$PIECE(TIME,U,I)
+97 FOR I=2,3
SET X=$PIECE(TIME,U,I)
IF X?7N.E
SET TIMEP(X)=""
+98 +99 SET MTYPEC=$$MSGTYPE^HLUCM009(IEN772)
+100 SET $PIECE(DATAC(IEN772),U,6)=MTYPEC
+101 SET MTYPEP=MTYPEP_$SELECT(MTYPEP]"":"~",1:"")_MTYPEC
+102 +103 SET PROT=$$PROT101^HLUCM002(+IEN772)
+104 SET $PIECE(DATAC(IEN772),U,7)=PROT
+105 if PROT]""
SET PROTP=PROT
+106 +107 SET NMSP=$$NMSPALL(+IEN772)
+108 SET $PIECE(DATAC(IEN772),U,9)=NMSP
+109 IF NMSP]""
Begin DoDot:2
+110 ;->
IF NMSPP]""
IF NMSP="XWB"
IF NMSPP'="XWB"
QUIT
+111 SET NMSPP=NMSP
End DoDot:2
+112 +113 SET $PIECE(DATAC(IEN772),U,11)=FAC
End DoDot:1
+114 ;
+115 SET TIMEBEG=$ORDER(TIMEP(0))
SET TIMEEND=$ORDER(TIMEP(":"),-1)
+116 SET TMDIFF=$$FMDIFF^XLFDT(TIMEEND,TIMEBEG,2)
+117 ;
+118 SET DATAP=CHARP_U_CT_U_TMDIFF_U_TIMEBEG_U_TIMEEND_U_MTYPEP_U_PROTP_U_U_NMSPP_U_U_FAC
+119 ;
+120 ; Set PARENT node...
+121 SET IENPAR=$ORDER(HLNMSP(0))
+122 SET TMP($JOB,"HLPARENT",+IENPAR)=DATAP
+123 ;
+124 ; Set CHILD nodes...
+125 SET IEN772=0
+126 FOR
SET IEN772=$ORDER(HLNMSP(IEN772))
if IEN772'>0
QUIT
Begin DoDot:1
+127 SET TMP($JOB,"HLCHILD",+IEN772)=IENPAR_"~"_$GET(DATAC(+IEN772))
End DoDot:1
+128 ;
+129 KILL HLNMSP
+130 MERGE HLNMSP=TMP($JOB)
+131 MERGE ^TMP($JOB)=TMP($JOB)
+132 ;
+133 QUIT NUM
+134 ;
OKALL(HLNMSP) ; Does every 772 entry have a valid .01 node?
+1 NEW FAIL,I772
+2 SET FAIL=0
SET I772=0
+3 FOR
SET I772=$ORDER(HLNMSP(I772))
if 'I772!(FAIL)
QUIT
Begin DoDot:1
+4 ;->
if $PIECE($GET(^HL(772,+I772,0)),U)?7N1"."1.N
QUIT
+5 SET FAIL=1
End DoDot:1
+6 QUIT 'FAIL
+7 ;
VAL3(IEN772,FAC) ; Return sort values...
+1 NEW TYPEHR,TYPEIO,TYPELR
+2 SET TYPEHR=$$TYPETMO^HLUCM002(+IEN772)
+3 SET TYPEIO=$$TYPEIO^HLUCM002(+IEN772)
+4 ;S TYPELR=$$TYPELR^HLUCM001(+IEN772,FAC)
+5 SET TYPELR=$SELECT(FAC["~DNS":"R",1:"L")
+6 QUIT TYPEHR_U_TYPEIO_U_TYPELR
+7 ;
TIME(IEN772) ; Times...
+1 NEW CT,DATA,IEN773,TMBEG,TMEND,TMDIFF
+2 DO TOT772T^HLUCM(+IEN772)
+3 SET IEN773=0
SET CT=0
+4 FOR
SET IEN773=$ORDER(^HLMA("B",+IEN772,IEN773))
if 'IEN773!(CT>20)
QUIT
Begin DoDot:1
+5 SET CT=CT+1
+6 DO TOT773T^HLUCM(+IEN773)
End DoDot:1
+7 DO TMDIFF^HLUCM
+8 QUIT DATA("DIFF")_U_DATA("START")_U_DATA("END")
+9 ;
+10 ;
CHAR(IEN772) ; Number characters...
+1 NEW CT,DATA,IEN773
+2 DO TOT772C^HLUCM(+IEN772)
+3 SET IEN773=0
SET CT=0
+4 FOR
SET IEN773=$ORDER(^HLMA("B",+IEN772,IEN773))
if 'IEN773!(CT>20)
QUIT
Begin DoDot:1
+5 SET CT=CT+1
+6 DO TOT773C^HLUCM(+IEN773)
End DoDot:1
+7 QUIT $GET(DATA("CHAR"))
+8 ;
GETNMSP(IEN772) ; The one and only place to ask for NAMESPACE...
+1 NEW HL,NMSP,NUM,PAR,VAL
+2 ;->
SET NUM=$$LOADEM^HLUCM050(+IEN772,.HL)
if NUM'>0
QUIT ""
+3 SET PAR=+$GET(HL("HLCHILD",+IEN772))
+4 SET VAL=$GET(HL("HLPARENT",+PAR))
+5 QUIT $PIECE(VAL,U,9)
+6 ;
GETPROT(IEN772) ; One & only place to ask for PROTOCOL...
+1 NEW HL,NMSP,NUM,PAR,VAL
+2 ;->
SET NUM=$$LOADEM^HLUCM050(+IEN772,.HL)
if NUM'>0
QUIT ""
+3 SET PAR=+$GET(HL("HLCHILD",+IEN772))
+4 SET VAL=$GET(HL("HLPARENT",+PAR))
+5 QUIT $PIECE(VAL,U,7)
+6 ;
HOLDTOT(X) DO HOLDTOT^HLUCM009(X)
QUIT
MSGID(X) DO MSGID^HLUCM009(X)
QUIT
+1 ;
NMSPALL(IEN772) ;Perform all attempts to find NMSP...
+1 NEW IEN101,IEN94,NMSP
+2 ;
+3 ; If SPR...
+4 ;->
SET NMSP=$$SPR(+IEN772)
if NMSP]""
QUIT $$NMSPCHG(NMSP)
+5 ;
+6 ; Check MSH segment...
+7 ;->
SET NMSP=$$MSH772^HLUCM003(+IEN772)
if NMSP]""
QUIT $$NMSPCHG(NMSP)
+8 ;->
SET NMSP=$$MSHMAIL^HLUCM003(+IEN772)
if NMSP]""
QUIT $$NMSPCHG(NMSP)
+9 ;
+10 ; Get Event Protocol
+11 ;->
SET IEN101=+$PIECE($GET(^HL(772,+IEN772,0)),U,10)
if IEN101'>0
QUIT ""
+12 ;
+13 ; Find XEC routines, and try NMSPXRFs...
+14 ;->
SET NMSP=$$NMSPXRF(+IEN101)
if NMSP]""
QUIT $$NMSPCHG(NMSP)
+15 ;
+16 ; Try 9.4 link...
+17 SET IEN94=$PIECE($GET(^ORD(101,+IEN101,0)),U,12)
+18 ;->
IF IEN94
SET NMSP=$PIECE($$NMSP94(IEN94),U,2)
if NMSP]""
QUIT $$NMSPCHG(NMSP)
+19 ;
+20 ;->
SET NMSP=$$MSH773^HLUCM003(+IEN772)
if NMSP]""
QUIT $$NMSPCHG(NMSP)
+21 ;
+22 QUIT ""
+23 ;
NMSP94(IEN94) ; From 9.4 find it's namespace...
+1 NEW D0,DA,DIC,DIQ,DR,NMSP,RET
+2 ;->
SET RET=$GET(^TMP($JOB,"HLNMSP94",+IEN94))
IF RET]""
QUIT RET
+3 SET DIC=9.4
SET DR=".01;1"
SET DA=IEN94
SET DIQ="NMSP("
SET DIQ(0)="E"
+4 DO EN^DIQ1
+5 SET RET=$GET(NMSP(9.4,+IEN94,.01,"E"))_U_$GET(NMSP(9.4,+IEN94,1,"E"))
+6 SET ^TMP($JOB,"HLNMSP94",+IEN94)=RET
+7 QUIT RET
+8 ;
NMSPCHG(NMSP) ; Some miscellaneous special actions first...
+1 NEW PCKG
+2 ;
+3 ; Check xref first...
+4 if '$DATA(^TMP($JOB,"HLNMSPXRF"))
DO NMSPXRF^HLUCM009
+5 ;->
SET PCKG=$$NMSPFROM(NMSP)
if PCKG]""
QUIT PCKG
+6 ;
+7 SET PCKG=NMSP
+8 ;
+9 ; Other conversions here...
+10 IF $EXTRACT(PCKG,1,2)="DG"
IF PCKG'="DG"
SET PCKG="DG"
+11 IF $EXTRACT(PCKG,1,3)="VEI"
IF PCKG'="VEIB"
SET PCKG="VEIB"
+12 IF $EXTRACT(PCKG,1,2)="VA"
Begin DoDot:1
+13 ;->
IF PCKG["PIMS"
SET PCKG="DG"
QUIT
+14 ;->
IF $GET(APPR)["HEC "
SET PCKG="HEC"
QUIT
+15 ;->
IF $GET(FACR)["HEC "
SET PCKG="HEC"
QUIT
End DoDot:1
+16 IF $EXTRACT(PCKG,1,2)="LA"
SET PCKG="LA"
+17 IF $EXTRACT(PCKG,1,2)="VA"
IF PCKG[" PIMS"
SET PCKG="DG"
+18 IF $EXTRACT(PCKG,1,10)="VAFC ADMIT"
SET PCKG="DG"
+19 IF $EXTRACT(PCKG,1,8)="VAFC ADT"
SET PCKG="DG"
+20 IF $EXTRACT(PCKG,1,8)?1"VAFH A"2N
SET PCKG="DG"
+21 IF $EXTRACT(PCKG,1,15)?1"VAFH CLIENT A"2N
SET PCKG="DG"
+22 IF $EXTRACT(PCKG,1,2)="XM"
SET PCKG="XM"
+23 IF $EXTRACT(PCKG,1,2)="XU"
SET PCKG="XU"
+24 ;
+25 QUIT PCKG
+26 ;
NMSPXRF(IEN101) ; Find NMSP from ^TMP($J,"NMSPXRF")
+1 NEW LEN,NMSP,NODE,RTN
+2 ; Build, if not there
IF '$DATA(^TMP($JOB,"HLNMSPXRF"))
DO NMSPXRF^HLUCM009
+3 SET NMSP=""
+4 FOR NODE=772,774,771
Begin DoDot:1
+5 ;->
SET RTN=$EXTRACT($PIECE($GET(^ORD(101,+IEN101,NODE)),U,2),1,4)
if RTN']""
QUIT
+6 SET NMSP=$$NMSPFROM(RTN)
End DoDot:1
if NMSP]""
QUIT
+7 QUIT NMSP
+8 ;
NMSPFROM(TXT) ; From TXT try to find NMSP...
+1 NEW NMSP
+2 ;->
if $GET(TXT)']""
QUIT ""
+3 SET NMSP=""
+4 FOR LEN=4:-1:2
Begin DoDot:1
+5 ;->
SET NMSP=$GET(^TMP($JOB,"HLNMSPXRF",$EXTRACT(TXT,1,LEN)))
if NMSP]""
QUIT
End DoDot:1
if NMSP]""
QUIT
+6 IF NMSP']""
FOR LEN=4:-1:2
Begin DoDot:1
+7 ; See Integration Agreement #10048
+8 NEW D,DIC,X,Y
+9 SET DIC="^DIC(9.4,"
SET DIC(0)="FO"
SET D="C"
SET X=$EXTRACT(TXT,1,LEN)
+10 ;->
DO MIX^DIC1
if +Y'>0
QUIT
+11 ; Found! So, set into ^TMP...
+12 SET NMSP=$EXTRACT(TXT,1,LEN)
+13 SET ^TMP($JOB,"HLNMSPXRF",NMSP)=NMSP
End DoDot:1
if NMSP]""
QUIT
+14 QUIT NMSP
+15 ;
SPR(IEN772) ; Evaluate SPR segment for RPC for package, possible
+1 ; resetting the PCKG variable...
+2 ; PCKG -- req
+3 NEW CHAR,DEL,IN,NMSP
+4 SET IN=$GET(^HL(772,+IEN772,"IN",1,0))
+5 ;->
if $EXTRACT(IN,1,4)'="SPR^"
QUIT ""
+6 ;->
if IN'["REMOTE RPC^"
QUIT ""
+7 SET DEL=$EXTRACT(IN,4)
+8 ;->
SET IN=$PIECE(IN,DEL,5)
if IN']""
QUIT ""
+9 ;->
SET IN=$PIECE(IN,"003RPC",2)
if IN']""
QUIT ""
+10 ;->
SET CHAR=+IN
SET IN=$TRANSLATE($EXTRACT(IN,4,CHAR+4),"&","")
if IN']""
QUIT ""
+11 ;->
IF $EXTRACT(IN,1,2)="IB"
QUIT "IB"
+12 ;->
IF $EXTRACT(IN,1,2)="OR"
QUIT "OR"
+13 IF '$DATA(^TMP($JOB,"HLNMSPXRF"))
DO NMSPXRF^HLUCM009
+14 SET NMSP=$$NMSPFROM(IN)
+15 QUIT NMSP
+16 ;
EOR ; HLUCM050 - HL7/Capacity Mgt API-II ;10/23/01 12:01
