| [613] | 1 | HLUCM090 ;CIOFO-O/LJA - Facility Finder Software ;2/20/2003 - 12:35
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**103,114**;Oct 13, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | FACILITY(IEN772) ; Return facility name for REMOTE entries
|
|---|
| 5 | ; IMPORTANT!! Do not call here unless the entry is REMOTE
|
|---|
| 6 | ;
|
|---|
| 7 | N FACNM
|
|---|
| 8 | N FACNM,IEN773,LOCAL,MSH,NO773
|
|---|
| 9 | ;
|
|---|
| 10 | ; Is FAC a local station number?
|
|---|
| 11 | S LOCAL=$P($$SITE^VASITE,U,3)_"~"_$P($$SITE^VASITE,U,2)_"~LOCAL"
|
|---|
| 12 | ;
|
|---|
| 13 | S IEN772=0,FACNM=""
|
|---|
| 14 | F S IEN772=$O(IEN772(IEN772)) Q:'IEN772!(FACNM]"") D
|
|---|
| 15 | . S FACNM=$$FACNM(+IEN772)
|
|---|
| 16 | ;
|
|---|
| 17 | Q $S(FACNM]"":FACNM,1:LOCAL)
|
|---|
| 18 | ;
|
|---|
| 19 | FACNM(IEN772) ; Return FACILITY NAME for one 772 entry...
|
|---|
| 20 | N CT,DATA,FACNM,MSH,NO,PROT
|
|---|
| 21 | ;
|
|---|
| 22 | ; Try to extract from MSH segment in file 773...
|
|---|
| 23 | S FACNM=$$MSH773(+IEN772) QUIT:FACNM]"" $$FACDNS(FACNM) ;->
|
|---|
| 24 | ;
|
|---|
| 25 | ; Try to find MSH in 772...
|
|---|
| 26 | S FACNM=$$SEG772(+IEN772) QUIT:FACNM]"" $$FACDNS(FACNM) ;->
|
|---|
| 27 | ;
|
|---|
| 28 | ; Try to find MSH in 870...
|
|---|
| 29 | S FACNM=$$MSH870(+IEN772) QUIT:FACNM]"" $$FACDNS(FACNM) ;->
|
|---|
| 30 | ;
|
|---|
| 31 | Q ""
|
|---|
| 32 | ;
|
|---|
| 33 | MSH870(IEN772) ; Find facility name from MSH in 870 OUT QUEUE...
|
|---|
| 34 | N CT,DATA,IEN772N,LL,MSH,NO,PROT,PROTS
|
|---|
| 35 | ;
|
|---|
| 36 | ; Look at parent...
|
|---|
| 37 | S IEN772N=+$G(^TMP($J,"HLOAD772","X",+IEN772))
|
|---|
| 38 | I IEN772N'>0 S IEN772N=+IEN772
|
|---|
| 39 | ;
|
|---|
| 40 | S PROT=$P($G(^HL(772,+IEN772N,0)),U,10) QUIT:'PROT "" ;->
|
|---|
| 41 | S FACNM="",PROTS=0
|
|---|
| 42 | F S PROTS=$O(^ORD(101,+PROT,775,"B",PROTS)) QUIT:'PROTS!(FACNM]"") D
|
|---|
| 43 | . S LL=$P($G(^ORD(101,+PROTS,770)),U,7) QUIT:'LL ;->
|
|---|
| 44 | . S MSH="",NO=0,CT=0
|
|---|
| 45 | . F S NO=$O(^HLCS(870,+LL,2,NO)) Q:MSH]""!('NO)!(CT>10)!(FACNM]"") D
|
|---|
| 46 | . . S CT=CT+1
|
|---|
| 47 | . . S DATA=$G(^HLCS(870,+LL,2,+NO,1,1,0)) QUIT:$E(DATA,1,3)'="MSH" ;->
|
|---|
| 48 | . . S MSH=DATA,FACNM=$$MSHXTRCT(MSH,"O")
|
|---|
| 49 | Q FACNM
|
|---|
| 50 | ;
|
|---|
| 51 | SEG772(IEN772) ; Try to find SEGment in 772, and extract facility...
|
|---|
| 52 | N SEG,WAY
|
|---|
| 53 | S WAY=$P($G(^HL(772,+IEN772,0)),U,4) QUIT:WAY']"" "" ;->
|
|---|
| 54 | S SEG=$G(^HL(772,+IEN772,"IN",1,0))
|
|---|
| 55 | I $E(SEG,1,3)="MSH" QUIT $$MSHXTRCT(SEG,WAY) ;->
|
|---|
| 56 | I $E(SEG,1,3)="SPR" QUIT $$SPRXTRCT(IEN772,SEG) ;->
|
|---|
| 57 | Q ""
|
|---|
| 58 | ;
|
|---|
| 59 | MSH773(IEN772) ; Try to extract from MSH segment in file 773...
|
|---|
| 60 | N FACNM,IEN773,NO773
|
|---|
| 61 | S NO773=$$IEN773(IEN772,.IEN773)
|
|---|
| 62 | I NO773 S FACNM=$O(IEN773("")) QUIT:FACNM]"" FACNM ;->
|
|---|
| 63 | Q ""
|
|---|
| 64 | ;
|
|---|
| 65 | IEN773(IEN772,IEN773) ; Find associated 773 entries...
|
|---|
| 66 | N DEL,IEN,MSH,RFN,VAL,WAY
|
|---|
| 67 | ;
|
|---|
| 68 | KILL IEN773
|
|---|
| 69 | S IEN773=0
|
|---|
| 70 | ;
|
|---|
| 71 | S IEN=0
|
|---|
| 72 | F S IEN=$O(^HLMA("B",+IEN772,IEN)) Q:'IEN D
|
|---|
| 73 | . S VAL=$G(^HLMA(+IEN,0)) QUIT:VAL']"" ;->
|
|---|
| 74 | . S WAY=$P(VAL,U,3) QUIT:WAY']"" ;->
|
|---|
| 75 | . S MSH=$G(^HLMA(+IEN,"MSH",1,0)) QUIT:MSH']"" ;->
|
|---|
| 76 | . S RFN=$$MSHXTRCT(MSH,WAY) QUIT:RFN']"" ;->
|
|---|
| 77 | . S IEN773(RFN,+IEN)=WAY
|
|---|
| 78 | . S IEN773(RFN)=$G(IEN773(RFN))+1
|
|---|
| 79 | . S IEN773=$G(IEN773)+1
|
|---|
| 80 | ;
|
|---|
| 81 | Q +IEN773
|
|---|
| 82 | ;
|
|---|
| 83 | MSHXTRCT(MSH,WAY) ; Given I/O WAY and MSH segment, return facility
|
|---|
| 84 | N DEL,RFN,X
|
|---|
| 85 | S DEL=$E(MSH,4)
|
|---|
| 86 | S RFN=$P(MSH,DEL,$S(WAY="I":4,WAY="O":6,1:999)) QUIT:RFN']"" "" ;->
|
|---|
| 87 | I RFN?3N!(RFN?3N1U.E) S X=$$FRSTANO(RFN) S:X]"" RFN=X
|
|---|
| 88 | Q RFN
|
|---|
| 89 | ;
|
|---|
| 90 | SPRXTRCT(IEN772,SPR) ; Given SPR segment, extract facility
|
|---|
| 91 | N CHAR,DIV,I773,MSH
|
|---|
| 92 | S I773=$O(^HLMA("B",+IEN772,0))
|
|---|
| 93 | S MSH=$G(^HLMA(+I773,"MSH",1,0))
|
|---|
| 94 | S DIV=$E(MSH,7)
|
|---|
| 95 | S:DIV']"" DIV="\"
|
|---|
| 96 | Q $P(SPR,DIV,5)
|
|---|
| 97 | ;
|
|---|
| 98 | FRSTANO(STANO) ;
|
|---|
| 99 | N IEN,NM
|
|---|
| 100 | S IEN=$O(^DIC(4,"D",STANO,0)) QUIT:IEN'>0 "" ;->
|
|---|
| 101 | S NM=$P($G(^DIC(4,+IEN,0)),U)
|
|---|
| 102 | QUIT NM
|
|---|
| 103 | ;
|
|---|
| 104 | ACCUMFAC ; Create ^TMP(TOTALS,$J,"RFAC") data...
|
|---|
| 105 | N INFO,PARENT,TYPE
|
|---|
| 106 | ;
|
|---|
| 107 | D ACCUMLAT^HLUCM009("RFAC","LR","R",FAC,DATA("PCKG"),START,DATA("PROT"))
|
|---|
| 108 | ;
|
|---|
| 109 | S TOTCURR=$G(^TMP(TOTALS,$J,"RFAC"))
|
|---|
| 110 | D INCR^HLUCM001
|
|---|
| 111 | S ^TMP(TOTALS,$J,"RFAC")=TOTCURR
|
|---|
| 112 | ;
|
|---|
| 113 | Q
|
|---|
| 114 | ;
|
|---|
| 115 | INST870(IEN772,INST) ;
|
|---|
| 116 | N INST870,LINK
|
|---|
| 117 | S LINK=$$LINK(IEN772) QUIT:LINK'>0 "" ;->
|
|---|
| 118 | S INST870=+$P($G(^HLCS(870,+LINK,0)),U,2)
|
|---|
| 119 | QUIT $S(INST870>0&(INST870'=INST):"R",1:"L")
|
|---|
| 120 | ;
|
|---|
| 121 | MAIL870(IEN772) ;
|
|---|
| 122 | N LINK,MAIL
|
|---|
| 123 | S LINK=$$LINK(IEN772) QUIT:LINK'>0 "" ;->
|
|---|
| 124 | S MAIL=$P($G(^HLCS(870,+LINK,0)),U,3)
|
|---|
| 125 | QUIT $S(MAIL=1:"R",1:"L")
|
|---|
| 126 | ;
|
|---|
| 127 | LINK(IEN772) ;
|
|---|
| 128 | N IEN773,LINK
|
|---|
| 129 | S LINK=$P($G(^HL(772,IEN772,0)),U,11)
|
|---|
| 130 | I LINK'>0 D
|
|---|
| 131 | . S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 ;->
|
|---|
| 132 | . S LINK=$P($G(^HLMA(+IEN773,0)),U,7)
|
|---|
| 133 | QUIT LINK
|
|---|
| 134 | ;
|
|---|
| 135 | PRINTDBG ; Print data in ^TMP($J,"HLUCMSTORE")
|
|---|
| 136 | N CHAR,CT,IEN772,IEN773,IOINHI,IOINORM,LP,PAUSE,PRINT
|
|---|
| 137 | N S1,S2,SKIP,ST,STOP,VAL
|
|---|
| 138 | I $G(JOBN)']"" N JOBN S JOBN=$J
|
|---|
| 139 | S X="IOINHI;IOINORM" D ENDR^%ZISS
|
|---|
| 140 | S LP=$NA(^TMP(JOBN,"HLUCMSTORE")),ST=$P(LP,")")_","
|
|---|
| 141 | ;
|
|---|
| 142 | R !!,"Print T nodes(Y/N): No// ",ANS:999 Q:ANS[U ;->
|
|---|
| 143 | S SKIP=$S(ANS=""!(ANS="N"):"",1:"T")
|
|---|
| 144 | ;
|
|---|
| 145 | R !!,"Print X nodes(Y/N): No// ",ANS:999 Q:ANS[U ;->
|
|---|
| 146 | S SKIP=SKIP_$S(ANS=""!(ANS="N"):"",1:"X")
|
|---|
| 147 | ;
|
|---|
| 148 | R !!,"Print U nodes(Y/N): Yes// ",ANS:999 Q:ANS[U ;->
|
|---|
| 149 | S SKIP=SKIP_$S(ANS=""!(ANS="Y"):"U",1:"")
|
|---|
| 150 | ;
|
|---|
| 151 | S CT=0,PAUSE=1,STOP=0
|
|---|
| 152 | F S LP=$Q(@LP) Q:LP'[ST!(STOP) D
|
|---|
| 153 | . S X=$E($TR($P(LP,",",3),"""","")_" ") I SKIP'[X QUIT ;->
|
|---|
| 154 | . S DATA=$P(LP,ST,2,99)_"=",PX=$L(DATA),DATA=IOINHI_DATA_IOINORM_@LP
|
|---|
| 155 | . F D Q:DATA']"" Q:STOP
|
|---|
| 156 | . . S PRINT=$E(DATA,1,77),DATA=$E(DATA,78,999)
|
|---|
| 157 | . . I DATA]"" S DATA=$$REPEAT^XLFSTR(" ",PX)_DATA
|
|---|
| 158 | . . W !,PRINT
|
|---|
| 159 | . QUIT:'PAUSE ;->
|
|---|
| 160 | . S CT=CT+1 QUIT:CT<22 ;->
|
|---|
| 161 | . W " ",IOINHI,"<",IOINORM
|
|---|
| 162 | . R X:999 S:X[U STOP=1 S:X=" " PAUSE=0
|
|---|
| 163 | . S CT=0
|
|---|
| 164 | QUIT
|
|---|
| 165 | ;
|
|---|
| 166 | PRINT1 ;
|
|---|
| 167 | N DATA,L1,L2,L3,L4,L5,LAST,TOT,TOT1,TOT2,TOT3,TYP
|
|---|
| 168 | PRINT2 I $G(GBL)']"" N GBL S GBL="^TMP("""_SUB_""","_JOBN_")"
|
|---|
| 169 | S (TOT,TOT1,TOT2,TOT3)=0
|
|---|
| 170 | I $O(@GBL@(""))']"" D QUIT ;->
|
|---|
| 171 | . S X=$$BTE^HLCSMON("No data found. Press RETURN to continue... ",1)
|
|---|
| 172 | S X=$$BTE^HLCSMON("About to print ^TMP("""_$G(SUB)_""",$J) data report. Press RETURN...",1)
|
|---|
| 173 | W !!," Total Total Total Main"
|
|---|
| 174 | W !,"#Chars #Msgs #Sec Sort Sub1 Sub2 Sub3"
|
|---|
| 175 | W !,$$REPEAT^XLFSTR("=",IOM)
|
|---|
| 176 | S L1=""
|
|---|
| 177 | F S L1=$O(@GBL@(L1)) Q:L1']"" D
|
|---|
| 178 | . S (TOT1,TOT2,TOT3)=0
|
|---|
| 179 | . S L2=""
|
|---|
| 180 | . F S L2=$O(@GBL@(L1,L2)) Q:L2']"" D
|
|---|
| 181 | . . S L3=""
|
|---|
| 182 | . . F S L3=$O(@GBL@(L1,L2,L3)) Q:L3']"" D
|
|---|
| 183 | . . . S L4=""
|
|---|
| 184 | . . . F S L4=$O(@GBL@(L1,L2,L3,L4)) Q:L4']"" D
|
|---|
| 185 | . . . . S TOT=$G(@GBL@(L1,L2,L3,L4))
|
|---|
| 186 | . . . . W !,$J(+TOT,6),?8,$J($P(TOT,U,2),6),?16,$J($P(TOT,U,3),6)
|
|---|
| 187 | . . . . W ?24,L1,?29,L2,?34,L3,?39,$S($L(L4)<42:L4,1:$E(L4,1,40)_"~")
|
|---|
| 188 | . . . . I L1="NMSP",L2'="IO" QUIT ;->
|
|---|
| 189 | . . . . S TOT1=TOT1+$P(TOT,U),TOT2=TOT2+$P(TOT,U,2),TOT3=TOT3+$P(TOT,U,3)
|
|---|
| 190 | . . . I L1="NMSP" S X=$O(@GBL@(L1,L2,L3)) I X]"",L3'=X W:WAY=1 !
|
|---|
| 191 | . . I L1="NMSP" S X=$O(@GBL@(L1,L2)) I X]"",L2'=X W:WAY=1 !
|
|---|
| 192 | . I WAY=1 W !,$$REPEAT^XLFSTR("-",IOM),!,$J(TOT1,6),?8,$J(TOT2,6),?16,$J(TOT3,6),!
|
|---|
| 193 | Q
|
|---|
| 194 | ;
|
|---|
| 195 | FACDNS(FAC) ; Return STA#~STA-NAME~DNS if remote...
|
|---|
| 196 | N FACNM,LOCAL
|
|---|
| 197 | ;
|
|---|
| 198 | ; Is FAC a local station number?
|
|---|
| 199 | S LOCAL=$P($$SITE^VASITE,U,3)_"~"_$P($$SITE^VASITE,U,2)_"~LOCAL"
|
|---|
| 200 | I +FAC=+LOCAL QUIT LOCAL ;->
|
|---|
| 201 | ;
|
|---|
| 202 | ; FAC not a station number, or not local...
|
|---|
| 203 | S FACNM=$$FACFROM(FAC)
|
|---|
| 204 | ;
|
|---|
| 205 | I +FACNM'>0 QUIT LOCAL ;-> No site number found...
|
|---|
| 206 | I +FACNM=+LOCAL QUIT LOCAL ;-> Local site number...
|
|---|
| 207 | ;
|
|---|
| 208 | QUIT:FACNM]"" FACNM ;->
|
|---|
| 209 | ;
|
|---|
| 210 | Q LOCAL
|
|---|
| 211 | ;
|
|---|
| 212 | FACFROM(FAC) ; Find STA#~STA-NAME~DNS if remote...
|
|---|
| 213 | N D,DIC,FACNM,STANO,X,Y
|
|---|
| 214 | ;
|
|---|
| 215 | QUIT:$G(FAC)']"" "" ;-> If no station number...
|
|---|
| 216 | ;
|
|---|
| 217 | ; Initial build of facility conversions...
|
|---|
| 218 | D:'$D(^TMP($J,"HL4")) BLDHL4
|
|---|
| 219 | ;
|
|---|
| 220 | ; If facility is in facility conversion in ^TMP($J,"HL4")...
|
|---|
| 221 | S FACNM=$G(^TMP($J,"HL4",FAC)) QUIT:FACNM]"" FACNM ;->
|
|---|
| 222 | ;
|
|---|
| 223 | ; Try to look up. (See Integration Agreement# 10090)
|
|---|
| 224 | ;
|
|---|
| 225 | ; Pure station number lookup if leading 3 station number digits...
|
|---|
| 226 | ; Otherwise, use the FACility name...
|
|---|
| 227 | S DIC="^DIC(4,",DIC(0)="FMO",D="B^D",X=$S(+FAC?3N:+FAC,1:FAC)
|
|---|
| 228 | D MIX^DIC1
|
|---|
| 229 | ;
|
|---|
| 230 | D FACVAR
|
|---|
| 231 | ;
|
|---|
| 232 | ; Success...
|
|---|
| 233 | I FACNM]"" D QUIT FACNM ;->
|
|---|
| 234 | . S FACNM=STANO_"~"_FACNM_"~DNS"
|
|---|
| 235 | . S ^TMP($J,"HL4",FAC)=FACNM
|
|---|
| 236 | ;
|
|---|
| 237 | ; Failed lookup...
|
|---|
| 238 | I FACNM']"",+FAC'?3N QUIT "" ;-> Lookup on alpha facility name
|
|---|
| 239 | I FACNM']"",+FAC=FAC QUIT "" ;-> Lookup on pure 3 digit station #
|
|---|
| 240 | ;
|
|---|
| 241 | ; Failed on lookup on ###, so try ###A...
|
|---|
| 242 | KILL D,DIC,X,Y
|
|---|
| 243 | S DIC="^DIC(4,",DIC(0)="FMO",D="B^D",X=FAC
|
|---|
| 244 | ;
|
|---|
| 245 | D FACVAR
|
|---|
| 246 | ;
|
|---|
| 247 | ; Success...
|
|---|
| 248 | I FACNM]"" D QUIT FACNM ;->
|
|---|
| 249 | . S FACNM=STANO_"~"_FACNM_"~DNS"
|
|---|
| 250 | . S ^TMP($J,"HL4",FAC)=FACNM
|
|---|
| 251 | ;
|
|---|
| 252 | Q ""
|
|---|
| 253 | ;
|
|---|
| 254 | FACVAR ; Set up variables...
|
|---|
| 255 | N DIC,X
|
|---|
| 256 | S FACNO=+$G(Y),FACNM=$P($G(Y),U,2),STANO="" ; HL*1.6*114
|
|---|
| 257 | QUIT:FACNO'>0 ;->
|
|---|
| 258 | S DIC=4,DR="99",DA=+FACNO,DIQ="DATA(",DIQ(0)="E"
|
|---|
| 259 | D EN^DIQ1
|
|---|
| 260 | S STANO=$G(DATA(4,+FACNO,99,"E"))
|
|---|
| 261 | Q
|
|---|
| 262 | ;
|
|---|
| 263 | BLDHL4 ; Build facility conversions...
|
|---|
| 264 | 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)
|
|---|
| 265 | ;;200M^200M~MPI~DNS
|
|---|
| 266 | ;;AUSTIN^200~AUSTIN~DNS
|
|---|
| 267 | Q
|
|---|
| 268 | ;
|
|---|
| 269 | EOR ;HLUCM090 - Facility Finder Software ;2/20/2003 - 12:35
|
|---|
