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