HLUCM090 ;CIOFO-O/LJA - Facility Finder Software ;2/20/2003 - 12:35
;;1.6;HEALTH LEVEL SEVEN;**103,114**;Oct 13, 1995
;
FACILITY(IEN772) ; Return facility name for REMOTE entries
; IMPORTANT!! Do not call here unless the entry is REMOTE
;
N FACNM
N FACNM,IEN773,LOCAL,MSH,NO773
;
; Is FAC a local station number?
S LOCAL=$P($$SITE^VASITE,U,3)_"~"_$P($$SITE^VASITE,U,2)_"~LOCAL"
;
S IEN772=0,FACNM=""
F S IEN772=$O(IEN772(IEN772)) Q:'IEN772!(FACNM]"") D
. S FACNM=$$FACNM(+IEN772)
;
Q $S(FACNM]"":FACNM,1:LOCAL)
;
FACNM(IEN772) ; Return FACILITY NAME for one 772 entry...
N CT,DATA,FACNM,MSH,NO,PROT
;
; Try to extract from MSH segment in file 773...
S FACNM=$$MSH773(+IEN772) QUIT:FACNM]"" $$FACDNS(FACNM) ;->
;
; Try to find MSH in 772...
S FACNM=$$SEG772(+IEN772) QUIT:FACNM]"" $$FACDNS(FACNM) ;->
;
; Try to find MSH in 870...
S FACNM=$$MSH870(+IEN772) QUIT:FACNM]"" $$FACDNS(FACNM) ;->
;
Q ""
;
MSH870(IEN772) ; Find facility name from MSH in 870 OUT QUEUE...
N CT,DATA,IEN772N,LL,MSH,NO,PROT,PROTS
;
; Look at parent...
S IEN772N=+$G(^TMP($J,"HLOAD772","X",+IEN772))
I IEN772N'>0 S IEN772N=+IEN772
;
S PROT=$P($G(^HL(772,+IEN772N,0)),U,10) QUIT:'PROT "" ;->
S FACNM="",PROTS=0
F S PROTS=$O(^ORD(101,+PROT,775,"B",PROTS)) QUIT:'PROTS!(FACNM]"") D
. S LL=$P($G(^ORD(101,+PROTS,770)),U,7) QUIT:'LL ;->
. S MSH="",NO=0,CT=0
. F S NO=$O(^HLCS(870,+LL,2,NO)) Q:MSH]""!('NO)!(CT>10)!(FACNM]"") D
. . S CT=CT+1
. . S DATA=$G(^HLCS(870,+LL,2,+NO,1,1,0)) QUIT:$E(DATA,1,3)'="MSH" ;->
. . S MSH=DATA,FACNM=$$MSHXTRCT(MSH,"O")
Q FACNM
;
SEG772(IEN772) ; Try to find SEGment in 772, and extract facility...
N SEG,WAY
S WAY=$P($G(^HL(772,+IEN772,0)),U,4) QUIT:WAY']"" "" ;->
S SEG=$G(^HL(772,+IEN772,"IN",1,0))
I $E(SEG,1,3)="MSH" QUIT $$MSHXTRCT(SEG,WAY) ;->
I $E(SEG,1,3)="SPR" QUIT $$SPRXTRCT(IEN772,SEG) ;->
Q ""
;
MSH773(IEN772) ; Try to extract from MSH segment in file 773...
N FACNM,IEN773,NO773
S NO773=$$IEN773(IEN772,.IEN773)
I NO773 S FACNM=$O(IEN773("")) QUIT:FACNM]"" FACNM ;->
Q ""
;
IEN773(IEN772,IEN773) ; Find associated 773 entries...
N DEL,IEN,MSH,RFN,VAL,WAY
;
KILL IEN773
S IEN773=0
;
S IEN=0
F S IEN=$O(^HLMA("B",+IEN772,IEN)) Q:'IEN D
. S VAL=$G(^HLMA(+IEN,0)) QUIT:VAL']"" ;->
. S WAY=$P(VAL,U,3) QUIT:WAY']"" ;->
. S MSH=$G(^HLMA(+IEN,"MSH",1,0)) QUIT:MSH']"" ;->
. S RFN=$$MSHXTRCT(MSH,WAY) QUIT:RFN']"" ;->
. S IEN773(RFN,+IEN)=WAY
. S IEN773(RFN)=$G(IEN773(RFN))+1
. S IEN773=$G(IEN773)+1
;
Q +IEN773
;
MSHXTRCT(MSH,WAY) ; Given I/O WAY and MSH segment, return facility
N DEL,RFN,X
S DEL=$E(MSH,4)
S RFN=$P(MSH,DEL,$S(WAY="I":4,WAY="O":6,1:999)) QUIT:RFN']"" "" ;->
I RFN?3N!(RFN?3N1U.E) S X=$$FRSTANO(RFN) S:X]"" RFN=X
Q RFN
;
SPRXTRCT(IEN772,SPR) ; Given SPR segment, extract facility
N CHAR,DIV,I773,MSH
S I773=$O(^HLMA("B",+IEN772,0))
S MSH=$G(^HLMA(+I773,"MSH",1,0))
S DIV=$E(MSH,7)
S:DIV']"" DIV="\"
Q $P(SPR,DIV,5)
;
FRSTANO(STANO) ;
N IEN,NM
S IEN=$O(^DIC(4,"D",STANO,0)) QUIT:IEN'>0 "" ;->
S NM=$P($G(^DIC(4,+IEN,0)),U)
QUIT NM
;
ACCUMFAC ; Create ^TMP(TOTALS,$J,"RFAC") data...
N INFO,PARENT,TYPE
;
D ACCUMLAT^HLUCM009("RFAC","LR","R",FAC,DATA("PCKG"),START,DATA("PROT"))
;
S TOTCURR=$G(^TMP(TOTALS,$J,"RFAC"))
D INCR^HLUCM001
S ^TMP(TOTALS,$J,"RFAC")=TOTCURR
;
Q
;
INST870(IEN772,INST) ;
N INST870,LINK
S LINK=$$LINK(IEN772) QUIT:LINK'>0 "" ;->
S INST870=+$P($G(^HLCS(870,+LINK,0)),U,2)
QUIT $S(INST870>0&(INST870'=INST):"R",1:"L")
;
MAIL870(IEN772) ;
N LINK,MAIL
S LINK=$$LINK(IEN772) QUIT:LINK'>0 "" ;->
S MAIL=$P($G(^HLCS(870,+LINK,0)),U,3)
QUIT $S(MAIL=1:"R",1:"L")
;
LINK(IEN772) ;
N IEN773,LINK
S LINK=$P($G(^HL(772,IEN772,0)),U,11)
I LINK'>0 D
. S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 ;->
. S LINK=$P($G(^HLMA(+IEN773,0)),U,7)
QUIT LINK
;
PRINTDBG ; Print data in ^TMP($J,"HLUCMSTORE")
N CHAR,CT,IEN772,IEN773,IOINHI,IOINORM,LP,PAUSE,PRINT
N S1,S2,SKIP,ST,STOP,VAL
I $G(JOBN)']"" N JOBN S JOBN=$J
S X="IOINHI;IOINORM" D ENDR^%ZISS
S LP=$NA(^TMP(JOBN,"HLUCMSTORE")),ST=$P(LP,")")_","
;
R !!,"Print T nodes(Y/N): No// ",ANS:999 Q:ANS[U ;->
S SKIP=$S(ANS=""!(ANS="N"):"",1:"T")
;
R !!,"Print X nodes(Y/N): No// ",ANS:999 Q:ANS[U ;->
S SKIP=SKIP_$S(ANS=""!(ANS="N"):"",1:"X")
;
R !!,"Print U nodes(Y/N): Yes// ",ANS:999 Q:ANS[U ;->
S SKIP=SKIP_$S(ANS=""!(ANS="Y"):"U",1:"")
;
S CT=0,PAUSE=1,STOP=0
F S LP=$Q(@LP) Q:LP'[ST!(STOP) D
. S X=$E($TR($P(LP,",",3),"""","")_" ") I SKIP'[X QUIT ;->
. S DATA=$P(LP,ST,2,99)_"=",PX=$L(DATA),DATA=IOINHI_DATA_IOINORM_@LP
. F D Q:DATA']"" Q:STOP
. . S PRINT=$E(DATA,1,77),DATA=$E(DATA,78,999)
. . I DATA]"" S DATA=$$REPEAT^XLFSTR(" ",PX)_DATA
. . W !,PRINT
. QUIT:'PAUSE ;->
. S CT=CT+1 QUIT:CT<22 ;->
. W " ",IOINHI,"<",IOINORM
. R X:999 S:X[U STOP=1 S:X=" " PAUSE=0
. S CT=0
QUIT
;
PRINT1 ;
N DATA,L1,L2,L3,L4,L5,LAST,TOT,TOT1,TOT2,TOT3,TYP
PRINT2 I $G(GBL)']"" N GBL S GBL="^TMP("""_SUB_""","_JOBN_")"
S (TOT,TOT1,TOT2,TOT3)=0
I $O(@GBL@(""))']"" D QUIT ;->
. S X=$$BTE^HLCSMON("No data found. Press RETURN to continue... ",1)
S X=$$BTE^HLCSMON("About to print ^TMP("""_$G(SUB)_""",$J) data report. Press RETURN...",1)
W !!," Total Total Total Main"
W !,"#Chars #Msgs #Sec Sort Sub1 Sub2 Sub3"
W !,$$REPEAT^XLFSTR("=",IOM)
S L1=""
F S L1=$O(@GBL@(L1)) Q:L1']"" D
. S (TOT1,TOT2,TOT3)=0
. S L2=""
. F S L2=$O(@GBL@(L1,L2)) Q:L2']"" D
. . S L3=""
. . F S L3=$O(@GBL@(L1,L2,L3)) Q:L3']"" D
. . . S L4=""
. . . F S L4=$O(@GBL@(L1,L2,L3,L4)) Q:L4']"" D
. . . . S TOT=$G(@GBL@(L1,L2,L3,L4))
. . . . W !,$J(+TOT,6),?8,$J($P(TOT,U,2),6),?16,$J($P(TOT,U,3),6)
. . . . W ?24,L1,?29,L2,?34,L3,?39,$S($L(L4)<42:L4,1:$E(L4,1,40)_"~")
. . . . I L1="NMSP",L2'="IO" QUIT ;->
. . . . S TOT1=TOT1+$P(TOT,U),TOT2=TOT2+$P(TOT,U,2),TOT3=TOT3+$P(TOT,U,3)
. . . I L1="NMSP" S X=$O(@GBL@(L1,L2,L3)) I X]"",L3'=X W:WAY=1 !
. . I L1="NMSP" S X=$O(@GBL@(L1,L2)) I X]"",L2'=X W:WAY=1 !
. I WAY=1 W !,$$REPEAT^XLFSTR("-",IOM),!,$J(TOT1,6),?8,$J(TOT2,6),?16,$J(TOT3,6),!
Q
;
FACDNS(FAC) ; Return STA#~STA-NAME~DNS if remote...
N FACNM,LOCAL
;
; Is FAC a local station number?
S LOCAL=$P($$SITE^VASITE,U,3)_"~"_$P($$SITE^VASITE,U,2)_"~LOCAL"
I +FAC=+LOCAL QUIT LOCAL ;->
;
; FAC not a station number, or not local...
S FACNM=$$FACFROM(FAC)
;
I +FACNM'>0 QUIT LOCAL ;-> No site number found...
I +FACNM=+LOCAL QUIT LOCAL ;-> Local site number...
;
QUIT:FACNM]"" FACNM ;->
;
Q LOCAL
;
FACFROM(FAC) ; Find STA#~STA-NAME~DNS if remote...
N D,DIC,FACNM,STANO,X,Y
;
QUIT:$G(FAC)']"" "" ;-> If no station number...
;
; Initial build of facility conversions...
D:'$D(^TMP($J,"HL4")) BLDHL4
;
; If facility is in facility conversion in ^TMP($J,"HL4")...
S FACNM=$G(^TMP($J,"HL4",FAC)) QUIT:FACNM]"" FACNM ;->
;
; Try to look up. (See Integration Agreement# 10090)
;
; Pure station number lookup if leading 3 station number digits...
; Otherwise, use the FACility name...
S DIC="^DIC(4,",DIC(0)="FMO",D="B^D",X=$S(+FAC?3N:+FAC,1:FAC)
D MIX^DIC1
;
D FACVAR
;
; Success...
I FACNM]"" D QUIT FACNM ;->
. S FACNM=STANO_"~"_FACNM_"~DNS"
. S ^TMP($J,"HL4",FAC)=FACNM
;
; Failed lookup...
I FACNM']"",+FAC'?3N QUIT "" ;-> Lookup on alpha facility name
I FACNM']"",+FAC=FAC QUIT "" ;-> Lookup on pure 3 digit station #
;
; Failed on lookup on ###, so try ###A...
KILL D,DIC,X,Y
S DIC="^DIC(4,",DIC(0)="FMO",D="B^D",X=FAC
;
D FACVAR
;
; Success...
I FACNM]"" D QUIT FACNM ;->
. S FACNM=STANO_"~"_FACNM_"~DNS"
. S ^TMP($J,"HL4",FAC)=FACNM
;
Q ""
;
FACVAR ; Set up variables...
N DIC,X
S FACNO=+$G(Y),FACNM=$P($G(Y),U,2),STANO="" ; HL*1.6*114
QUIT:FACNO'>0 ;->
S DIC=4,DR="99",DA=+FACNO,DIQ="DATA(",DIQ(0)="E"
D EN^DIQ1
S STANO=$G(DATA(4,+FACNO,99,"E"))
Q
;
BLDHL4 ; Build facility conversions...
N I,T F I=2:1 S T=$T(BLDHL4+I) Q:T'[";;" S T=$P(T,";;",2,99),^TMP($J,"HL4",$P(T,U))=$P(T,U,2)
;;200M^200M~MPI~DNS
;;AUSTIN^200~AUSTIN~DNS
Q
;
EOR ;HLUCM090 - Facility Finder Software ;2/20/2003 - 12:35
HLUCM090 ;CIOFO-O/LJA - Facility Finder Software ;2/20/2003 - 12:35
+1 ;;1.6;HEALTH LEVEL SEVEN;**103,114**;Oct 13, 1995
+2 ;
FACILITY(IEN772) ; Return facility name for REMOTE entries
+1 ; IMPORTANT!! Do not call here unless the entry is REMOTE
+2 ;
+3 NEW FACNM
+4 NEW FACNM,IEN773,LOCAL,MSH,NO773
+5 ;
+6 ; Is FAC a local station number?
+7 SET LOCAL=$PIECE($$SITE^VASITE,U,3)_"~"_$PIECE($$SITE^VASITE,U,2)_"~LOCAL"
+8 ;
+9 SET IEN772=0
SET FACNM=""
+10 FOR
SET IEN772=$ORDER(IEN772(IEN772))
IF 'IEN772!(FACNM]"")
QUIT
Begin DoDot:1
+11 SET FACNM=$$FACNM(+IEN772)
End DoDot:1
+12 ;
+13 QUIT $SELECT(FACNM]"":FACNM,1:LOCAL)
+14 ;
FACNM(IEN772) ; Return FACILITY NAME for one 772 entry...
+1 NEW CT,DATA,FACNM,MSH,NO,PROT
+2 ;
+3 ; Try to extract from MSH segment in file 773...
+4 ;->
SET FACNM=$$MSH773(+IEN772)
IF FACNM]""
QUIT $$FACDNS(FACNM)
+5 ;
+6 ; Try to find MSH in 772...
+7 ;->
SET FACNM=$$SEG772(+IEN772)
IF FACNM]""
QUIT $$FACDNS(FACNM)
+8 ;
+9 ; Try to find MSH in 870...
+10 ;->
SET FACNM=$$MSH870(+IEN772)
IF FACNM]""
QUIT $$FACDNS(FACNM)
+11 ;
+12 QUIT ""
+13 ;
MSH870(IEN772) ; Find facility name from MSH in 870 OUT QUEUE...
+1 NEW CT,DATA,IEN772N,LL,MSH,NO,PROT,PROTS
+2 ;
+3 ; Look at parent...
+4 SET IEN772N=+$GET(^TMP($JOB,"HLOAD772","X",+IEN772))
+5 IF IEN772N'>0
SET IEN772N=+IEN772
+6 ;
+7 ;->
SET PROT=$PIECE($GET(^HL(772,+IEN772N,0)),U,10)
IF 'PROT
QUIT ""
+8 SET FACNM=""
SET PROTS=0
+9 FOR
SET PROTS=$ORDER(^ORD(101,+PROT,775,"B",PROTS))
IF 'PROTS!(FACNM]"")
QUIT
Begin DoDot:1
+10 ;->
SET LL=$PIECE($GET(^ORD(101,+PROTS,770)),U,7)
IF 'LL
QUIT
+11 SET MSH=""
SET NO=0
SET CT=0
+12 FOR
SET NO=$ORDER(^HLCS(870,+LL,2,NO))
IF MSH]""!('NO)!(CT>10)!(FACNM]"")
QUIT
Begin DoDot:2
+13 SET CT=CT+1
+14 ;->
SET DATA=$GET(^HLCS(870,+LL,2,+NO,1,1,0))
IF $EXTRACT(DATA,1,3)'="MSH"
QUIT
+15 SET MSH=DATA
SET FACNM=$$MSHXTRCT(MSH,"O")
End DoDot:2
End DoDot:1
+16 QUIT FACNM
+17 ;
SEG772(IEN772) ; Try to find SEGment in 772, and extract facility...
+1 NEW SEG,WAY
+2 ;->
SET WAY=$PIECE($GET(^HL(772,+IEN772,0)),U,4)
IF WAY']""
QUIT ""
+3 SET SEG=$GET(^HL(772,+IEN772,"IN",1,0))
+4 ;->
IF $EXTRACT(SEG,1,3)="MSH"
QUIT $$MSHXTRCT(SEG,WAY)
+5 ;->
IF $EXTRACT(SEG,1,3)="SPR"
QUIT $$SPRXTRCT(IEN772,SEG)
+6 QUIT ""
+7 ;
MSH773(IEN772) ; Try to extract from MSH segment in file 773...
+1 NEW FACNM,IEN773,NO773
+2 SET NO773=$$IEN773(IEN772,.IEN773)
+3 ;->
IF NO773
SET FACNM=$ORDER(IEN773(""))
IF FACNM]""
QUIT FACNM
+4 QUIT ""
+5 ;
IEN773(IEN772,IEN773) ; Find associated 773 entries...
+1 NEW DEL,IEN,MSH,RFN,VAL,WAY
+2 ;
+3 KILL IEN773
+4 SET IEN773=0
+5 ;
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^HLMA("B",+IEN772,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+8 ;->
SET VAL=$GET(^HLMA(+IEN,0))
IF VAL']""
QUIT
+9 ;->
SET WAY=$PIECE(VAL,U,3)
IF WAY']""
QUIT
+10 ;->
SET MSH=$GET(^HLMA(+IEN,"MSH",1,0))
IF MSH']""
QUIT
+11 ;->
SET RFN=$$MSHXTRCT(MSH,WAY)
IF RFN']""
QUIT
+12 SET IEN773(RFN,+IEN)=WAY
+13 SET IEN773(RFN)=$GET(IEN773(RFN))+1
+14 SET IEN773=$GET(IEN773)+1
End DoDot:1
+15 ;
+16 QUIT +IEN773
+17 ;
MSHXTRCT(MSH,WAY) ; Given I/O WAY and MSH segment, return facility
+1 NEW DEL,RFN,X
+2 SET DEL=$EXTRACT(MSH,4)
+3 ;->
SET RFN=$PIECE(MSH,DEL,$SELECT(WAY="I":4,WAY="O":6,1:999))
IF RFN']""
QUIT ""
+4 IF RFN?3N!(RFN?3N1U.E)
SET X=$$FRSTANO(RFN)
IF X]""
SET RFN=X
+5 QUIT RFN
+6 ;
SPRXTRCT(IEN772,SPR) ; Given SPR segment, extract facility
+1 NEW CHAR,DIV,I773,MSH
+2 SET I773=$ORDER(^HLMA("B",+IEN772,0))
+3 SET MSH=$GET(^HLMA(+I773,"MSH",1,0))
+4 SET DIV=$EXTRACT(MSH,7)
+5 IF DIV']""
SET DIV="\"
+6 QUIT $PIECE(SPR,DIV,5)
+7 ;
FRSTANO(STANO) ;
+1 NEW IEN,NM
+2 ;->
SET IEN=$ORDER(^DIC(4,"D",STANO,0))
IF IEN'>0
QUIT ""
+3 SET NM=$PIECE($GET(^DIC(4,+IEN,0)),U)
+4 QUIT NM
+5 ;
ACCUMFAC ; Create ^TMP(TOTALS,$J,"RFAC") data...
+1 NEW INFO,PARENT,TYPE
+2 ;
+3 DO ACCUMLAT^HLUCM009("RFAC","LR","R",FAC,DATA("PCKG"),START,DATA("PROT"))
+4 ;
+5 SET TOTCURR=$GET(^TMP(TOTALS,$JOB,"RFAC"))
+6 DO INCR^HLUCM001
+7 SET ^TMP(TOTALS,$JOB,"RFAC")=TOTCURR
+8 ;
+9 QUIT
+10 ;
INST870(IEN772,INST) ;
+1 NEW INST870,LINK
+2 ;->
SET LINK=$$LINK(IEN772)
IF LINK'>0
QUIT ""
+3 SET INST870=+$PIECE($GET(^HLCS(870,+LINK,0)),U,2)
+4 QUIT $SELECT(INST870>0&(INST870'=INST):"R",1:"L")
+5 ;
MAIL870(IEN772) ;
+1 NEW LINK,MAIL
+2 ;->
SET LINK=$$LINK(IEN772)
IF LINK'>0
QUIT ""
+3 SET MAIL=$PIECE($GET(^HLCS(870,+LINK,0)),U,3)
+4 QUIT $SELECT(MAIL=1:"R",1:"L")
+5 ;
LINK(IEN772) ;
+1 NEW IEN773,LINK
+2 SET LINK=$PIECE($GET(^HL(772,IEN772,0)),U,11)
+3 IF LINK'>0
Begin DoDot:1
+4 ;->
SET IEN773=$ORDER(^HLMA("B",IEN772,0))
IF IEN773'>0
QUIT
+5 SET LINK=$PIECE($GET(^HLMA(+IEN773,0)),U,7)
End DoDot:1
+6 QUIT LINK
+7 ;
PRINTDBG ; Print data in ^TMP($J,"HLUCMSTORE")
+1 NEW CHAR,CT,IEN772,IEN773,IOINHI,IOINORM,LP,PAUSE,PRINT
+2 NEW S1,S2,SKIP,ST,STOP,VAL
+3 IF $GET(JOBN)']""
NEW JOBN
SET JOBN=$JOB
+4 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+5 SET LP=$NAME(^TMP(JOBN,"HLUCMSTORE"))
SET ST=$PIECE(LP,")")_","
+6 ;
+7 ;->
READ !!,"Print T nodes(Y/N): No// ",ANS:999
IF ANS[U
QUIT
+8 SET SKIP=$SELECT(ANS=""!(ANS="N"):"",1:"T")
+9 ;
+10 ;->
READ !!,"Print X nodes(Y/N): No// ",ANS:999
IF ANS[U
QUIT
+11 SET SKIP=SKIP_$SELECT(ANS=""!(ANS="N"):"",1:"X")
+12 ;
+13 ;->
READ !!,"Print U nodes(Y/N): Yes// ",ANS:999
IF ANS[U
QUIT
+14 SET SKIP=SKIP_$SELECT(ANS=""!(ANS="Y"):"U",1:"")
+15 ;
+16 SET CT=0
SET PAUSE=1
SET STOP=0
+17 FOR
SET LP=$QUERY(@LP)
IF LP'[ST!(STOP)
QUIT
Begin DoDot:1
+18 ;->
SET X=$EXTRACT($TRANSLATE($PIECE(LP,",",3),"""","")_" ")
IF SKIP'[X
QUIT
+19 SET DATA=$PIECE(LP,ST,2,99)_"="
SET PX=$LENGTH(DATA)
SET DATA=IOINHI_DATA_IOINORM_@LP
+20 FOR
Begin DoDot:2
+21 SET PRINT=$EXTRACT(DATA,1,77)
SET DATA=$EXTRACT(DATA,78,999)
+22 IF DATA]""
SET DATA=$$REPEAT^XLFSTR(" ",PX)_DATA
+23 WRITE !,PRINT
End DoDot:2
IF DATA']""
QUIT
IF STOP
QUIT
+24 ;->
IF 'PAUSE
QUIT
+25 ;->
SET CT=CT+1
IF CT<22
QUIT
+26 WRITE " ",IOINHI,"<",IOINORM
+27 READ X:999
IF X[U
SET STOP=1
IF X=" "
SET PAUSE=0
+28 SET CT=0
End DoDot:1
+29 QUIT
+30 ;
PRINT1 ;
+1 NEW DATA,L1,L2,L3,L4,L5,LAST,TOT,TOT1,TOT2,TOT3,TYP
PRINT2 IF $GET(GBL)']""
NEW GBL
SET GBL="^TMP("""_SUB_""","_JOBN_")"
+1 SET (TOT,TOT1,TOT2,TOT3)=0
+2 ;->
IF $ORDER(@GBL@(""))']""
Begin DoDot:1
+3 SET X=$$BTE^HLCSMON("No data found. Press RETURN to continue... ",1)
End DoDot:1
QUIT
+4 SET X=$$BTE^HLCSMON("About to print ^TMP("""_$GET(SUB)_""",$J) data report. Press RETURN...",1)
+5 WRITE !!," Total Total Total Main"
+6 WRITE !,"#Chars #Msgs #Sec Sort Sub1 Sub2 Sub3"
+7 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+8 SET L1=""
+9 FOR
SET L1=$ORDER(@GBL@(L1))
IF L1']""
QUIT
Begin DoDot:1
+10 SET (TOT1,TOT2,TOT3)=0
+11 SET L2=""
+12 FOR
SET L2=$ORDER(@GBL@(L1,L2))
IF L2']""
QUIT
Begin DoDot:2
+13 SET L3=""
+14 FOR
SET L3=$ORDER(@GBL@(L1,L2,L3))
IF L3']""
QUIT
Begin DoDot:3
+15 SET L4=""
+16 FOR
SET L4=$ORDER(@GBL@(L1,L2,L3,L4))
IF L4']""
QUIT
Begin DoDot:4
+17 SET TOT=$GET(@GBL@(L1,L2,L3,L4))
+18 WRITE !,$JUSTIFY(+TOT,6),?8,$JUSTIFY($PIECE(TOT,U,2),6),?16,$JUSTIFY($PIECE(TOT,U,3),6)
+19 WRITE ?24,L1,?29,L2,?34,L3,?39,$SELECT($LENGTH(L4)<42:L4,1:$EXTRACT(L4,1,40)_"~")
+20 ;->
IF L1="NMSP"
IF L2'="IO"
QUIT
+21 SET TOT1=TOT1+$PIECE(TOT,U)
SET TOT2=TOT2+$PIECE(TOT,U,2)
SET TOT3=TOT3+$PIECE(TOT,U,3)
End DoDot:4
+22 IF L1="NMSP"
SET X=$ORDER(@GBL@(L1,L2,L3))
IF X]""
IF L3'=X
IF WAY=1
WRITE !
End DoDot:3
+23 IF L1="NMSP"
SET X=$ORDER(@GBL@(L1,L2))
IF X]""
IF L2'=X
IF WAY=1
WRITE !
End DoDot:2
+24 IF WAY=1
WRITE !,$$REPEAT^XLFSTR("-",IOM),!,$JUSTIFY(TOT1,6),?8,$JUSTIFY(TOT2,6),?16,$JUSTIFY(TOT3,6),!
End DoDot:1
+25 QUIT
+26 ;
FACDNS(FAC) ; Return STA#~STA-NAME~DNS if remote...
+1 NEW FACNM,LOCAL
+2 ;
+3 ; Is FAC a local station number?
+4 SET LOCAL=$PIECE($$SITE^VASITE,U,3)_"~"_$PIECE($$SITE^VASITE,U,2)_"~LOCAL"
+5 ;->
IF +FAC=+LOCAL
QUIT LOCAL
+6 ;
+7 ; FAC not a station number, or not local...
+8 SET FACNM=$$FACFROM(FAC)
+9 ;
+10 ;-> No site number found...
IF +FACNM'>0
QUIT LOCAL
+11 ;-> Local site number...
IF +FACNM=+LOCAL
QUIT LOCAL
+12 ;
+13 ;->
IF FACNM]""
QUIT FACNM
+14 ;
+15 QUIT LOCAL
+16 ;
FACFROM(FAC) ; Find STA#~STA-NAME~DNS if remote...
+1 NEW D,DIC,FACNM,STANO,X,Y
+2 ;
+3 ;-> If no station number...
IF $GET(FAC)']""
QUIT ""
+4 ;
+5 ; Initial build of facility conversions...
+6 IF '$DATA(^TMP($JOB,"HL4"))
DO BLDHL4
+7 ;
+8 ; If facility is in facility conversion in ^TMP($J,"HL4")...
+9 ;->
SET FACNM=$GET(^TMP($JOB,"HL4",FAC))
IF FACNM]""
QUIT FACNM
+10 ;
+11 ; Try to look up. (See Integration Agreement# 10090)
+12 ;
+13 ; Pure station number lookup if leading 3 station number digits...
+14 ; Otherwise, use the FACility name...
+15 SET DIC="^DIC(4,"
SET DIC(0)="FMO"
SET D="B^D"
SET X=$SELECT(+FAC?3N:+FAC,1:FAC)
+16 DO MIX^DIC1
+17 ;
+18 DO FACVAR
+19 ;
+20 ; Success...
+21 ;->
IF FACNM]""
Begin DoDot:1
+22 SET FACNM=STANO_"~"_FACNM_"~DNS"
+23 SET ^TMP($JOB,"HL4",FAC)=FACNM
End DoDot:1
QUIT FACNM
+24 ;
+25 ; Failed lookup...
+26 ;-> Lookup on alpha facility name
IF FACNM']""
IF +FAC'?3N
QUIT ""
+27 ;-> Lookup on pure 3 digit station #
IF FACNM']""
IF +FAC=FAC
QUIT ""
+28 ;
+29 ; Failed on lookup on ###, so try ###A...
+30 KILL D,DIC,X,Y
+31 SET DIC="^DIC(4,"
SET DIC(0)="FMO"
SET D="B^D"
SET X=FAC
+32 ;
+33 DO FACVAR
+34 ;
+35 ; Success...
+36 ;->
IF FACNM]""
Begin DoDot:1
+37 SET FACNM=STANO_"~"_FACNM_"~DNS"
+38 SET ^TMP($JOB,"HL4",FAC)=FACNM
End DoDot:1
QUIT FACNM
+39 ;
+40 QUIT ""
+41 ;
FACVAR ; Set up variables...
+1 NEW DIC,X
+2 ; HL*1.6*114
SET FACNO=+$GET(Y)
SET FACNM=$PIECE($GET(Y),U,2)
SET STANO=""
+3 ;->
IF FACNO'>0
QUIT
+4 SET DIC=4
SET DR="99"
SET DA=+FACNO
SET DIQ="DATA("
SET DIQ(0)="E"
+5 DO EN^DIQ1
+6 SET STANO=$GET(DATA(4,+FACNO,99,"E"))
+7 QUIT
+8 ;
BLDHL4 ; Build facility conversions...
+1 NEW I,T
FOR I=2:1
SET T=$TEXT(BLDHL4+I)
IF T'[";;"
QUIT
SET T=$PIECE(T,";;",2,99)
SET ^TMP($JOB,"HL4",$PIECE(T,U))=$PIECE(T,U,2)
+2 ;;200M^200M~MPI~DNS
+3 ;;AUSTIN^200~AUSTIN~DNS
+4 QUIT
+5 ;
EOR ;HLUCM090 - Facility Finder Software ;2/20/2003 - 12:35
