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 Sep 23, 2025@19:36:19 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
