- HLUCM002 ;CIOFO-O/LJA - HL7/Capacity Mgt API ;2/27/01 10:15
- ;;1.6;HEALTH LEVEL SEVEN;**79,88,103**;Oct 13, 1995
- ;
- PRINTREG ; Print data in ^TMP(SUB,...) to screen
- ; SUB,JOBN -- req
- N DEB,GBL,IOINHI,IOINORM,JOBN,SUB,TOT,WAY,X,XTMPGBL
- ;
- S X="IOINHI;IOINORM" D ENDR^%ZISS
- ;
- W @IOF,$$CJ^XLFSTR("Print Totals Report & Debug Data to Screen",IOM)
- W !,$$REPEAT^XLFSTR("=",IOM)
- ;
- S XTMPGBL=""
- ;
- ; What is the SUB for the Totals Report...
- S SUB=$$SUB
- I SUB']"" W !!,"OK! No ^TMP(TOTALS,$J) totals report will be printed..."
- I SUB]"" D PTOT
- ;
- ; Debug data...
- I '$D(^TMP($J,"HLUCMSTORE")) D
- . W !!,"No ^TMP($J,""HLUCMSTORE"") debug data exists..."
- I $D(^TMP($J,"HLUCMSTORE")) D PSTORE
- ;
- I SUB']"",'$D(^TMP($J,"HLUCMSTORE")) D QUIT ;->
- . S X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
- ;
- QUIT:$$BTE^HLCSMON("Press RETURN to restart, or '^' to exit... ",1) ;->
- ;
- G PRINTREG ;->
- ;
- PSTORE ;
- W !!,$$CJ^XLFSTR("----------- "_IOINHI_"Debug Data from ^TMP($J,""HLUCMSTORE"")"_IOINORM_" -----------",IOM)
- R !!,"Print raw DEBUG DATA (Y/N): Yes// ",X:999 S:X="" X="Y" S DEB=$$UP^XLFSTR($E(X_" ")) Q:'$T!(DEB[U) ;->
- I DEB="Y" D PRINTDBG^HLUCM090
- ;
- R !!,"Print filtered DEBUG DATA (Y/N): Yes// ",X:999 S:X="" X="Y" S DEB=$$UP^XLFSTR($E(X_" ")) Q:'$T!(DEB[U) ;->
- I DEB="Y" D LOOPU^HLUCM004
- Q
- ;
- PTOT ;
- W !!,"You will be allowed to print report totals (from ^TMP(TOTALS,$J), and/or you"
- W !,"may print the debug data (in ^TMP($J,""HLUCMSTORE"")."
- W !!,$$CJ^XLFSTR("------------ "_IOINHI_"Report Totals from ^TMP("""_SUB_""",$J)"_IOINORM_" ------------",IOM)
- R !!,"Print REPORT TOTALS (Y/N): Yes// ",X:999 S:X="" X="Y" S TOT=$$UP^XLFSTR($E(X_" ")) Q:'$T!(TOT[U) ;->
- I TOT="Y" D
- . S SUB="TOT",JOBN=$J
- . I '$D(^TMP(SUB,JOBN)) S SUB="KMPDH"
- . R !,"Include subtotals (Y/N): NO// ",WAY:999 QUIT:'$T!(WAY[U) ;->
- . S:WAY']"" WAY="N"
- . S WAY=$$UP^XLFSTR($E(WAY_" ")),WAY=$S(WAY="N":0,1:1)
- . S X=$$XTMPGBL^HLUCM004(0) I X]"" S (GBL,XTMPGBL)=X W !!,"Printing from ",XTMPGBL,"..."
- . D PRINT1
- Q
- ;
- SUB() ; What subscript holds the ^TMP(SUB,$J) data?
- N SUB
- I $D(^TMP("KMPDH",$J)) QUIT "KMPDH" ;->
- I $D(^TMP("TOT",$J)) QUIT "TOT" ;->
- R !!,"Enter subscript holding the ^TMP(TOTALS,$J) data: ",SUB:999 Q:SUB[U!(SUB']"") "" ;->
- Q SUB
- ;
- PRINT(SUB,JOBN,WAY) ; Print data in ^TMP(SUB,...) to screen
- ; WAY -- 0 = No totals
- ; 1 = Totals for every section
- N L1,L2,L3
- ;
- S WAY=$S($G(WAY)'>0:0,$G(WAY)=1:1,1:0)
- ;
- S:$G(JOBN)'>0 JOBN=$J
- I $G(SUB)']"" D QUIT ;->
- . W !!,"You must pass in the initial subscript and $JOB number..."
- . W !
- PRINT1 D PRINT1^HLUCM090
- ;
- S GBL=$NA(^TMP($J,"HLUCMSTORE","T"))
- S L1=0 F L2="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $D(@GBL@(L2)) S L1=1
- QUIT:'L1 ;->
- ;
- W !!,"Some entries were not included in the totals. There are 3 possible reasons"
- W !,"for entries being excluded: (1) The beginning time of a message or unit is"
- W !,"before the report's start time, (2) The number of seconds to transmit the"
- W !,"message is over 1799 seconds, and (3) The protocol or namespace doesn't meet"
- W !,"the search criteria."
- W !!,"Failure Reason",?30,"#Characters",?42,"#Msg/Units",?54,"#Seconds"
- W !,$$REPEAT^XLFSTR("=",IOM)
- ;
- F LAST="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $G(@GBL@(LAST))]"" Q
- ;
- S TYP="XXX",DATA=$G(@GBL@(TYP)) I DATA]"" D
- . D SHOW("Beginning time too early",DATA)
- . D SHOW("Excessive xmit time")
- . D SHOW("Prot/Nmsp mismatch","",1)
- S TYP="XXC",DATA=$G(@GBL@("XXC")) I DATA]"" D
- . D SHOW("Beginning time too early",DATA)
- . D SHOW("Excessive xmit time","",1)
- S TYP="XCX",DATA=$G(@GBL@("XCX")) I DATA]"" D
- . D SHOW("Beginning time too early",DATA)
- . D SHOW("Prot/Nmsp mismatch","",1)
- S TYP="XCC",DATA=$G(@GBL@("XCC")) I DATA]"" D
- . D SHOW("Beginning time too early",DATA,1)
- S TYP="CXX",DATA=$G(@GBL@("CXX")) I DATA]"" D
- . D SHOW("Excessive xmit time",DATA)
- . D SHOW("Prot/Nmsp mismatch","",1)
- S TYP="CXC",DATA=$G(@GBL@("CXC")) I DATA]"" D
- . D SHOW("Excessive xmit time",DATA,1)
- S TYP="CCX",DATA=$G(@GBL@("CCX")) I DATA]"" D
- . D SHOW("Prot/Nmsp mismatch",DATA,1)
- I L1!L2!L3 W !,$$REPEAT^XLFSTR("=",IOM),!,"Totals:",?30,$J(L1,7),?42,$J(L2,7),?54,$J(L3,7)
- ;
- Q
- ;
- SHOW(REA,DATA,LINE) ;
- ; LAST,TYP -- req
- S DATA=$G(DATA),LINE=$G(LINE)
- W !,REA
- I $G(DATA)]"" W ?30,$J($P(DATA,U),7),?42,$J($P(DATA,U,2),7),?54,$J($P(DATA,U,3),7)
- I $G(LINE),TYP'=LAST W !,$$REPEAT^XLFSTR("-",IOM)
- S L1=$G(L1)+$P(DATA,U),L2=$G(L2)+$P(DATA,U,2),L3=$G(L3)+$P(DATA,U,3)
- QUIT
- ;
- ADD(TL) ; Add to TOT...
- S $P(TOT,U)=$P(TOT,U)+$P(TL,U)
- S $P(TOT,U,2)=$P(TOT,U,2)+$P(TL,U,2)
- S $P(TOT,U,3)=$P(TOT,U,3)+$P(TL,U,3)
- Q
- ;
- OKPAR(PAR) ; Is namespace or protocol OK?
- S PAR=$G(PAR)
- I PAR=1!(PAR=2) QUIT 1 ;->
- I $$OK0CALL(PAR) QUIT 1 ;->
- QUIT ""
- ;
- OK0CALL(PAR) ; Correct 0^IEN or 0^NAME call format?
- I $E(PAR,1,2)="0^"&($E(PAR,3)]"") QUIT 1 ;->
- QUIT ""
- ;
- TYPETMO(IEN772) ; Is this TCP, Mail (via TCP), or Other?
- N D772,I773,MIEN
- ;
- ; RELATED MAILMAN MESSAGE field (0;5) in 772...
- S D772=$G(^HL(772,+IEN772,0)) ; Get node
- S MIEN=$P(D772,U,5) ; get Mailman IEN from field...
- I MIEN QUIT "M" ;-> Mailman via TCP
- ;
- ; There are rare instances when RELATED MAILMAN MESSAGE field is
- ; not filled in, but the LLP TYPE in 870 is Mailman. So, the next
- ; check is needed...
- ;
- ; Get related 870 and check it's LLP TYPE...
- I $P($G(^HLCS(870,+$$IEN870^HLUCM009(+IEN772),0)),U,3)=1 QUIT "M" ;->
- ;
- ; OK. Let's give up on proving this 772 entry a Mailman entry.
- ; But, is it TCP?
- ;
- ; Check if TCP by 773 link...
- S I773=$O(^HLMA("B",+IEN772,0))
- I I773>0 QUIT "T" ;->
- ;
- QUIT "U" ; Other...
- ;
- TYPEIO(IEN772) ; Is this Input or Output or Unknown?
- N D772,HLIO
- S D772=$G(^HL(772,+IEN772,0))
- S HLIO=$E($P(D772,U,4)_" ")
- QUIT $S("IO"[HLIO:HLIO,1:"U")
- ;
- PROTNMSP(IEN772) ; Return PROT~NMSP value to store in ^TMP.
- ; COND,IEN101,PNMSP -- req
- N CT,FAIL,PCKG,CTPROT,PCKG,PROT
- ;
- S IEN101=$G(IEN101),PNMSP=$G(PNMSP)
- ;
- ; ======================== PROTOCOL ============================
- ; Get actual protocol in IEN772 if not supposed to "lump"...
- S PROT=$S(IEN101'=2:$$GETPROT^HLUCM050(+IEN772),1:"ZZZ")
- ;
- ; Don't lose count if supposed to check everything...
- I IEN101=1!(IEN101=2) D
- . I PROT']"" S PROT="ZZZ" QUIT ;->
- . I IEN101=2 S PROT="ZZZ"
- ;
- ; Is the protocol countable? (Must also check namespace)
- S CTPROT=$$CTPROT^HLUCM003(PROT)
- ;
- ; ======================== NAMESPACE ============================
- ; Set package here and now...
- S PCKG=$S(PNMSP'=2:$$GETNMSP^HLUCM050(+IEN772),1:"ZZZ")
- ;
- I PNMSP=1!(PNMSP=2) D
- . I PCKG']"" S PCKG="ZZZ" QUIT ;->
- . I PNMSP=2 S PCKG="ZZZ"
- ;
- S CTPCKG=$$CTPCKG^HLUCM003(PCKG)
- ;
- ;
- ; Set up what should be returned...
- S PROT=$S(PROT=2:"ZZZ",1:PROT),PCKG=$S(PCKG=2:"ZZZ",1:PCKG)
- ; If MIXED make sure the ALL side of things is set to something
- ; so the ALL side doesn't squelch a SPECIFIC match...
- I $$MIXED D
- . I $G(PNMSP)=1!($G(PNMSP)=2) D
- . . QUIT:PROT]"" ;->
- . . QUIT:'CTPROT ;-> Not to be counted anyway...
- . . S PROT="ZZZ~0"
- . I $G(IEN101)=1!($G(IEN101)=2) D
- . . QUIT:PCKG]"" ;->
- . . QUIT:'CTPCKG ;-> Not to be counted anyway...
- . . S PCKG="ZZZ"
- I '$$MIXED,COND="EITHER" D
- . QUIT:$$ALL($G(PNMSP),$G(IEN101)) ;-> All 1s or 2s...
- . I NMSPTYPE'=1 D ; Asked specifically...
- . . QUIT:PROT]"" ;->
- . . S PROT="ZZZ~0"
- . I PROTYPE'=1 D ; Asked specifically...
- . . QUIT:PCKG]"" ;->
- . . S PCKG="ZZZ"
- ;
- ; If neither should be counted, don't...
- I 'CTPROT&('CTPCKG) QUIT U ;->
- ;
- ; Either namespace or protocol matches, or both match...
- ;
- ; If BOTH namespace and protocol are required to match, don't count if one isn't a match...
- I COND="BOTH" I 'CTPROT!('CTPCKG) QUIT U ;->
- ;
- ; If 1/2 & SPECIFIC (i.e., MIXED), then SPECIFIC trumps 1/2...
- ; (If SPECIFIC not matched, it is not counted)
- I $$MIXED D QUIT:FAIL U ;->
- . S FAIL=1
- . ; If ALL NMSPs to be counted, but specific PROT fails... BAD!
- . I $G(PNMSP)=1!($G(PNMSP)=2) QUIT:'CTPROT ;->
- . ; If ALL PROTs to be counted, but specific PCKG fails... BAD!
- . I $G(IEN101)=1!($G(IEN101)=2) QUIT:'CTPCKG ;->
- . S FAIL=0
- ;
- QUIT PROT_U_PCKG
- ;
- ALL(V1,V2) ; Are both 1 or 2?
- S V1=$G(V1),V2=$G(V2)
- QUIT:V1'=1&(V1'=2) "" ;->
- QUIT:V2'=1&(V2'=2) "" ;->
- QUIT 1
- ;
- MIXED() ; Is one 1/2 and the other SPECIFIC?
- N V3
- S V1=$G(PNMSP),V1=$S(V1]"":$S(V1=1!(V1=2):1,1:0),1:0)
- S V2=$G(IEN101),V2=$S(V2]"":$S(V2=1!(V2=2):1,1:0),1:0)
- S V1=$S(V1=1!(V1=2):1,1:0)
- S V2=$S(V2=1!(V2=2):1,1:0)
- S V3=V1+V2
- QUIT $S(V3=1:1,1:"")
- ;
- PROT101(IEN772) ; Return 101 information...
- N IEN,MIEN,NM
- ;
- ; Get normal protocol information
- S IEN=$P($G(^HL(772,IEN772,0)),U,10)
- S NM=$P($G(^ORD(101,+IEN,0)),U)
- ;
- ; Maybe this is a Mailman ptr only...
- I NM']"",IEN'>0 D
- . S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 ;->
- . S NM="XMB",IEN=9999999
- ;
- QUIT $S(NM]""!(IEN>0):NM_"~"_IEN,1:"")
- ;
- EOR ; HLUCM002 - HL7/Capacity Mgt API ;2/27/01 10:15
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUCM002 9180 printed Feb 18, 2025@23:26:36 Page 2
- HLUCM002 ;CIOFO-O/LJA - HL7/Capacity Mgt API ;2/27/01 10:15
- +1 ;;1.6;HEALTH LEVEL SEVEN;**79,88,103**;Oct 13, 1995
- +2 ;
- PRINTREG ; Print data in ^TMP(SUB,...) to screen
- +1 ; SUB,JOBN -- req
- +2 NEW DEB,GBL,IOINHI,IOINORM,JOBN,SUB,TOT,WAY,X,XTMPGBL
- +3 ;
- +4 SET X="IOINHI;IOINORM"
- DO ENDR^%ZISS
- +5 ;
- +6 WRITE @IOF,$$CJ^XLFSTR("Print Totals Report & Debug Data to Screen",IOM)
- +7 WRITE !,$$REPEAT^XLFSTR("=",IOM)
- +8 ;
- +9 SET XTMPGBL=""
- +10 ;
- +11 ; What is the SUB for the Totals Report...
- +12 SET SUB=$$SUB
- +13 IF SUB']""
- WRITE !!,"OK! No ^TMP(TOTALS,$J) totals report will be printed..."
- +14 IF SUB]""
- DO PTOT
- +15 ;
- +16 ; Debug data...
- +17 IF '$DATA(^TMP($JOB,"HLUCMSTORE"))
- Begin DoDot:1
- +18 WRITE !!,"No ^TMP($J,""HLUCMSTORE"") debug data exists..."
- End DoDot:1
- +19 IF $DATA(^TMP($JOB,"HLUCMSTORE"))
- DO PSTORE
- +20 ;
- +21 ;->
- IF SUB']""
- IF '$DATA(^TMP($JOB,"HLUCMSTORE"))
- Begin DoDot:1
- +22 SET X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
- End DoDot:1
- QUIT
- +23 ;
- +24 ;->
- if $$BTE^HLCSMON("Press RETURN to restart, or '^' to exit... ",1)
- QUIT
- +25 ;
- +26 ;->
- GOTO PRINTREG
- +27 ;
- PSTORE ;
- +1 WRITE !!,$$CJ^XLFSTR("----------- "_IOINHI_"Debug Data from ^TMP($J,""HLUCMSTORE"")"_IOINORM_" -----------",IOM)
- +2 ;->
- READ !!,"Print raw DEBUG DATA (Y/N): Yes// ",X:999
- if X=""
- SET X="Y"
- SET DEB=$$UP^XLFSTR($EXTRACT(X_" "))
- if '$TEST!(DEB[U)
- QUIT
- +3 IF DEB="Y"
- DO PRINTDBG^HLUCM090
- +4 ;
- +5 ;->
- READ !!,"Print filtered DEBUG DATA (Y/N): Yes// ",X:999
- if X=""
- SET X="Y"
- SET DEB=$$UP^XLFSTR($EXTRACT(X_" "))
- if '$TEST!(DEB[U)
- QUIT
- +6 IF DEB="Y"
- DO LOOPU^HLUCM004
- +7 QUIT
- +8 ;
- PTOT ;
- +1 WRITE !!,"You will be allowed to print report totals (from ^TMP(TOTALS,$J), and/or you"
- +2 WRITE !,"may print the debug data (in ^TMP($J,""HLUCMSTORE"")."
- +3 WRITE !!,$$CJ^XLFSTR("------------ "_IOINHI_"Report Totals from ^TMP("""_SUB_""",$J)"_IOINORM_" ------------",IOM)
- +4 ;->
- READ !!,"Print REPORT TOTALS (Y/N): Yes// ",X:999
- if X=""
- SET X="Y"
- SET TOT=$$UP^XLFSTR($EXTRACT(X_" "))
- if '$TEST!(TOT[U)
- QUIT
- +5 IF TOT="Y"
- Begin DoDot:1
- +6 SET SUB="TOT"
- SET JOBN=$JOB
- +7 IF '$DATA(^TMP(SUB,JOBN))
- SET SUB="KMPDH"
- +8 ;->
- READ !,"Include subtotals (Y/N): NO// ",WAY:999
- if '$TEST!(WAY[U)
- QUIT
- +9 if WAY']""
- SET WAY="N"
- +10 SET WAY=$$UP^XLFSTR($EXTRACT(WAY_" "))
- SET WAY=$SELECT(WAY="N":0,1:1)
- +11 SET X=$$XTMPGBL^HLUCM004(0)
- IF X]""
- SET (GBL,XTMPGBL)=X
- WRITE !!,"Printing from ",XTMPGBL,"..."
- +12 DO PRINT1
- End DoDot:1
- +13 QUIT
- +14 ;
- SUB() ; What subscript holds the ^TMP(SUB,$J) data?
- +1 NEW SUB
- +2 ;->
- IF $DATA(^TMP("KMPDH",$JOB))
- QUIT "KMPDH"
- +3 ;->
- IF $DATA(^TMP("TOT",$JOB))
- QUIT "TOT"
- +4 ;->
- READ !!,"Enter subscript holding the ^TMP(TOTALS,$J) data: ",SUB:999
- if SUB[U!(SUB']"")
- QUIT ""
- +5 QUIT SUB
- +6 ;
- PRINT(SUB,JOBN,WAY) ; Print data in ^TMP(SUB,...) to screen
- +1 ; WAY -- 0 = No totals
- +2 ; 1 = Totals for every section
- +3 NEW L1,L2,L3
- +4 ;
- +5 SET WAY=$SELECT($GET(WAY)'>0:0,$GET(WAY)=1:1,1:0)
- +6 ;
- +7 if $GET(JOBN)'>0
- SET JOBN=$JOB
- +8 ;->
- IF $GET(SUB)']""
- Begin DoDot:1
- +9 WRITE !!,"You must pass in the initial subscript and $JOB number..."
- +10 WRITE !
- End DoDot:1
- QUIT
- PRINT1 DO PRINT1^HLUCM090
- +1 ;
- +2 SET GBL=$NAME(^TMP($JOB,"HLUCMSTORE","T"))
- +3 SET L1=0
- FOR L2="CCX","CXC","CXX","XCC","XCX","XXC","XXX"
- IF $DATA(@GBL@(L2))
- SET L1=1
- +4 ;->
- if 'L1
- QUIT
- +5 ;
- +6 WRITE !!,"Some entries were not included in the totals. There are 3 possible reasons"
- +7 WRITE !,"for entries being excluded: (1) The beginning time of a message or unit is"
- +8 WRITE !,"before the report's start time, (2) The number of seconds to transmit the"
- +9 WRITE !,"message is over 1799 seconds, and (3) The protocol or namespace doesn't meet"
- +10 WRITE !,"the search criteria."
- +11 WRITE !!,"Failure Reason",?30,"#Characters",?42,"#Msg/Units",?54,"#Seconds"
- +12 WRITE !,$$REPEAT^XLFSTR("=",IOM)
- +13 ;
- +14 FOR LAST="CCX","CXC","CXX","XCC","XCX","XXC","XXX"
- IF $GET(@GBL@(LAST))]""
- QUIT
- +15 ;
- +16 SET TYP="XXX"
- SET DATA=$GET(@GBL@(TYP))
- IF DATA]""
- Begin DoDot:1
- +17 DO SHOW("Beginning time too early",DATA)
- +18 DO SHOW("Excessive xmit time")
- +19 DO SHOW("Prot/Nmsp mismatch","",1)
- End DoDot:1
- +20 SET TYP="XXC"
- SET DATA=$GET(@GBL@("XXC"))
- IF DATA]""
- Begin DoDot:1
- +21 DO SHOW("Beginning time too early",DATA)
- +22 DO SHOW("Excessive xmit time","",1)
- End DoDot:1
- +23 SET TYP="XCX"
- SET DATA=$GET(@GBL@("XCX"))
- IF DATA]""
- Begin DoDot:1
- +24 DO SHOW("Beginning time too early",DATA)
- +25 DO SHOW("Prot/Nmsp mismatch","",1)
- End DoDot:1
- +26 SET TYP="XCC"
- SET DATA=$GET(@GBL@("XCC"))
- IF DATA]""
- Begin DoDot:1
- +27 DO SHOW("Beginning time too early",DATA,1)
- End DoDot:1
- +28 SET TYP="CXX"
- SET DATA=$GET(@GBL@("CXX"))
- IF DATA]""
- Begin DoDot:1
- +29 DO SHOW("Excessive xmit time",DATA)
- +30 DO SHOW("Prot/Nmsp mismatch","",1)
- End DoDot:1
- +31 SET TYP="CXC"
- SET DATA=$GET(@GBL@("CXC"))
- IF DATA]""
- Begin DoDot:1
- +32 DO SHOW("Excessive xmit time",DATA,1)
- End DoDot:1
- +33 SET TYP="CCX"
- SET DATA=$GET(@GBL@("CCX"))
- IF DATA]""
- Begin DoDot:1
- +34 DO SHOW("Prot/Nmsp mismatch",DATA,1)
- End DoDot:1
- +35 IF L1!L2!L3
- WRITE !,$$REPEAT^XLFSTR("=",IOM),!,"Totals:",?30,$JUSTIFY(L1,7),?42,$JUSTIFY(L2,7),?54,$JUSTIFY(L3,7)
- +36 ;
- +37 QUIT
- +38 ;
- SHOW(REA,DATA,LINE) ;
- +1 ; LAST,TYP -- req
- +2 SET DATA=$GET(DATA)
- SET LINE=$GET(LINE)
- +3 WRITE !,REA
- +4 IF $GET(DATA)]""
- WRITE ?30,$JUSTIFY($PIECE(DATA,U),7),?42,$JUSTIFY($PIECE(DATA,U,2),7),?54,$JUSTIFY($PIECE(DATA,U,3),7)
- +5 IF $GET(LINE)
- IF TYP'=LAST
- WRITE !,$$REPEAT^XLFSTR("-",IOM)
- +6 SET L1=$GET(L1)+$PIECE(DATA,U)
- SET L2=$GET(L2)+$PIECE(DATA,U,2)
- SET L3=$GET(L3)+$PIECE(DATA,U,3)
- +7 QUIT
- +8 ;
- ADD(TL) ; Add to TOT...
- +1 SET $PIECE(TOT,U)=$PIECE(TOT,U)+$PIECE(TL,U)
- +2 SET $PIECE(TOT,U,2)=$PIECE(TOT,U,2)+$PIECE(TL,U,2)
- +3 SET $PIECE(TOT,U,3)=$PIECE(TOT,U,3)+$PIECE(TL,U,3)
- +4 QUIT
- +5 ;
- OKPAR(PAR) ; Is namespace or protocol OK?
- +1 SET PAR=$GET(PAR)
- +2 ;->
- IF PAR=1!(PAR=2)
- QUIT 1
- +3 ;->
- IF $$OK0CALL(PAR)
- QUIT 1
- +4 QUIT ""
- +5 ;
- OK0CALL(PAR) ; Correct 0^IEN or 0^NAME call format?
- +1 ;->
- IF $EXTRACT(PAR,1,2)="0^"&($EXTRACT(PAR,3)]"")
- QUIT 1
- +2 QUIT ""
- +3 ;
- TYPETMO(IEN772) ; Is this TCP, Mail (via TCP), or Other?
- +1 NEW D772,I773,MIEN
- +2 ;
- +3 ; RELATED MAILMAN MESSAGE field (0;5) in 772...
- +4 ; Get node
- SET D772=$GET(^HL(772,+IEN772,0))
- +5 ; get Mailman IEN from field...
- SET MIEN=$PIECE(D772,U,5)
- +6 ;-> Mailman via TCP
- IF MIEN
- QUIT "M"
- +7 ;
- +8 ; There are rare instances when RELATED MAILMAN MESSAGE field is
- +9 ; not filled in, but the LLP TYPE in 870 is Mailman. So, the next
- +10 ; check is needed...
- +11 ;
- +12 ; Get related 870 and check it's LLP TYPE...
- +13 ;->
- IF $PIECE($GET(^HLCS(870,+$$IEN870^HLUCM009(+IEN772),0)),U,3)=1
- QUIT "M"
- +14 ;
- +15 ; OK. Let's give up on proving this 772 entry a Mailman entry.
- +16 ; But, is it TCP?
- +17 ;
- +18 ; Check if TCP by 773 link...
- +19 SET I773=$ORDER(^HLMA("B",+IEN772,0))
- +20 ;->
- IF I773>0
- QUIT "T"
- +21 ;
- +22 ; Other...
- QUIT "U"
- +23 ;
- TYPEIO(IEN772) ; Is this Input or Output or Unknown?
- +1 NEW D772,HLIO
- +2 SET D772=$GET(^HL(772,+IEN772,0))
- +3 SET HLIO=$EXTRACT($PIECE(D772,U,4)_" ")
- +4 QUIT $SELECT("IO"[HLIO:HLIO,1:"U")
- +5 ;
- PROTNMSP(IEN772) ; Return PROT~NMSP value to store in ^TMP.
- +1 ; COND,IEN101,PNMSP -- req
- +2 NEW CT,FAIL,PCKG,CTPROT,PCKG,PROT
- +3 ;
- +4 SET IEN101=$GET(IEN101)
- SET PNMSP=$GET(PNMSP)
- +5 ;
- +6 ; ======================== PROTOCOL ============================
- +7 ; Get actual protocol in IEN772 if not supposed to "lump"...
- +8 SET PROT=$SELECT(IEN101'=2:$$GETPROT^HLUCM050(+IEN772),1:"ZZZ")
- +9 ;
- +10 ; Don't lose count if supposed to check everything...
- +11 IF IEN101=1!(IEN101=2)
- Begin DoDot:1
- +12 ;->
- IF PROT']""
- SET PROT="ZZZ"
- QUIT
- +13 IF IEN101=2
- SET PROT="ZZZ"
- End DoDot:1
- +14 ;
- +15 ; Is the protocol countable? (Must also check namespace)
- +16 SET CTPROT=$$CTPROT^HLUCM003(PROT)
- +17 ;
- +18 ; ======================== NAMESPACE ============================
- +19 ; Set package here and now...
- +20 SET PCKG=$SELECT(PNMSP'=2:$$GETNMSP^HLUCM050(+IEN772),1:"ZZZ")
- +21 ;
- +22 IF PNMSP=1!(PNMSP=2)
- Begin DoDot:1
- +23 ;->
- IF PCKG']""
- SET PCKG="ZZZ"
- QUIT
- +24 IF PNMSP=2
- SET PCKG="ZZZ"
- End DoDot:1
- +25 ;
- +26 SET CTPCKG=$$CTPCKG^HLUCM003(PCKG)
- +27 ;
- +28 ;
- +29 ; Set up what should be returned...
- +30 SET PROT=$SELECT(PROT=2:"ZZZ",1:PROT)
- SET PCKG=$SELECT(PCKG=2:"ZZZ",1:PCKG)
- +31 ; If MIXED make sure the ALL side of things is set to something
- +32 ; so the ALL side doesn't squelch a SPECIFIC match...
- +33 IF $$MIXED
- Begin DoDot:1
- +34 IF $GET(PNMSP)=1!($GET(PNMSP)=2)
- Begin DoDot:2
- +35 ;->
- if PROT]""
- QUIT
- +36 ;-> Not to be counted anyway...
- if 'CTPROT
- QUIT
- +37 SET PROT="ZZZ~0"
- End DoDot:2
- +38 IF $GET(IEN101)=1!($GET(IEN101)=2)
- Begin DoDot:2
- +39 ;->
- if PCKG]""
- QUIT
- +40 ;-> Not to be counted anyway...
- if 'CTPCKG
- QUIT
- +41 SET PCKG="ZZZ"
- End DoDot:2
- End DoDot:1
- +42 IF '$$MIXED
- IF COND="EITHER"
- Begin DoDot:1
- +43 ;-> All 1s or 2s...
- if $$ALL($GET(PNMSP),$GET(IEN101))
- QUIT
- +44 ; Asked specifically...
- IF NMSPTYPE'=1
- Begin DoDot:2
- +45 ;->
- if PROT]""
- QUIT
- +46 SET PROT="ZZZ~0"
- End DoDot:2
- +47 ; Asked specifically...
- IF PROTYPE'=1
- Begin DoDot:2
- +48 ;->
- if PCKG]""
- QUIT
- +49 SET PCKG="ZZZ"
- End DoDot:2
- End DoDot:1
- +50 ;
- +51 ; If neither should be counted, don't...
- +52 ;->
- IF 'CTPROT&('CTPCKG)
- QUIT U
- +53 ;
- +54 ; Either namespace or protocol matches, or both match...
- +55 ;
- +56 ; If BOTH namespace and protocol are required to match, don't count if one isn't a match...
- +57 ;->
- IF COND="BOTH"
- IF 'CTPROT!('CTPCKG)
- QUIT U
- +58 ;
- +59 ; If 1/2 & SPECIFIC (i.e., MIXED), then SPECIFIC trumps 1/2...
- +60 ; (If SPECIFIC not matched, it is not counted)
- +61 ;->
- IF $$MIXED
- Begin DoDot:1
- +62 SET FAIL=1
- +63 ; If ALL NMSPs to be counted, but specific PROT fails... BAD!
- +64 ;->
- IF $GET(PNMSP)=1!($GET(PNMSP)=2)
- if 'CTPROT
- QUIT
- +65 ; If ALL PROTs to be counted, but specific PCKG fails... BAD!
- +66 ;->
- IF $GET(IEN101)=1!($GET(IEN101)=2)
- if 'CTPCKG
- QUIT
- +67 SET FAIL=0
- End DoDot:1
- if FAIL
- QUIT U
- +68 ;
- +69 QUIT PROT_U_PCKG
- +70 ;
- ALL(V1,V2) ; Are both 1 or 2?
- +1 SET V1=$GET(V1)
- SET V2=$GET(V2)
- +2 ;->
- if V1'=1&(V1'=2)
- QUIT ""
- +3 ;->
- if V2'=1&(V2'=2)
- QUIT ""
- +4 QUIT 1
- +5 ;
- MIXED() ; Is one 1/2 and the other SPECIFIC?
- +1 NEW V3
- +2 SET V1=$GET(PNMSP)
- SET V1=$SELECT(V1]"":$SELECT(V1=1!(V1=2):1,1:0),1:0)
- +3 SET V2=$GET(IEN101)
- SET V2=$SELECT(V2]"":$SELECT(V2=1!(V2=2):1,1:0),1:0)
- +4 SET V1=$SELECT(V1=1!(V1=2):1,1:0)
- +5 SET V2=$SELECT(V2=1!(V2=2):1,1:0)
- +6 SET V3=V1+V2
- +7 QUIT $SELECT(V3=1:1,1:"")
- +8 ;
- PROT101(IEN772) ; Return 101 information...
- +1 NEW IEN,MIEN,NM
- +2 ;
- +3 ; Get normal protocol information
- +4 SET IEN=$PIECE($GET(^HL(772,IEN772,0)),U,10)
- +5 SET NM=$PIECE($GET(^ORD(101,+IEN,0)),U)
- +6 ;
- +7 ; Maybe this is a Mailman ptr only...
- +8 IF NM']""
- IF IEN'>0
- Begin DoDot:1
- +9 ;->
- SET MIEN=$PIECE($GET(^HL(772,+IEN772,0)),U,5)
- if MIEN'>0
- QUIT
- +10 SET NM="XMB"
- SET IEN=9999999
- End DoDot:1
- +11 ;
- +12 QUIT $SELECT(NM]""!(IEN>0):NM_"~"_IEN,1:"")
- +13 ;
- EOR ; HLUCM002 - HL7/Capacity Mgt API ;2/27/01 10:15