Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLUCM090

HLUCM090.m

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