- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUCM090 8380 printed Feb 18, 2025@23:26:41 Page 2
- 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