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

HLUCM002.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. PRINTREG ; Print data in ^TMP(SUB,...) to screen
  1. ; SUB,JOBN -- req
  1. N DEB,GBL,IOINHI,IOINORM,JOBN,SUB,TOT,WAY,X,XTMPGBL
  1. ;
  1. S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. ;
  1. W @IOF,$$CJ^XLFSTR("Print Totals Report & Debug Data to Screen",IOM)
  1. W !,$$REPEAT^XLFSTR("=",IOM)
  1. ;
  1. S XTMPGBL=""
  1. ;
  1. ; What is the SUB for the Totals Report...
  1. S SUB=$$SUB
  1. I SUB']"" W !!,"OK! No ^TMP(TOTALS,$J) totals report will be printed..."
  1. I SUB]"" D PTOT
  1. ;
  1. ; Debug data...
  1. I '$D(^TMP($J,"HLUCMSTORE")) D
  1. . W !!,"No ^TMP($J,""HLUCMSTORE"") debug data exists..."
  1. I $D(^TMP($J,"HLUCMSTORE")) D PSTORE
  1. ;
  1. I SUB']"",'$D(^TMP($J,"HLUCMSTORE")) D QUIT ;->
  1. . S X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
  1. ;
  1. QUIT:$$BTE^HLCSMON("Press RETURN to restart, or '^' to exit... ",1) ;->
  1. ;
  1. G PRINTREG ;->
  1. ;
  1. PSTORE ;
  1. W !!,$$CJ^XLFSTR("----------- "_IOINHI_"Debug Data from ^TMP($J,""HLUCMSTORE"")"_IOINORM_" -----------",IOM)
  1. R !!,"Print raw DEBUG DATA (Y/N): Yes// ",X:999 S:X="" X="Y" S DEB=$$UP^XLFSTR($E(X_" ")) Q:'$T!(DEB[U) ;->
  1. I DEB="Y" D PRINTDBG^HLUCM090
  1. ;
  1. R !!,"Print filtered DEBUG DATA (Y/N): Yes// ",X:999 S:X="" X="Y" S DEB=$$UP^XLFSTR($E(X_" ")) Q:'$T!(DEB[U) ;->
  1. I DEB="Y" D LOOPU^HLUCM004
  1. Q
  1. ;
  1. PTOT ;
  1. W !!,"You will be allowed to print report totals (from ^TMP(TOTALS,$J), and/or you"
  1. W !,"may print the debug data (in ^TMP($J,""HLUCMSTORE"")."
  1. W !!,$$CJ^XLFSTR("------------ "_IOINHI_"Report Totals from ^TMP("""_SUB_""",$J)"_IOINORM_" ------------",IOM)
  1. R !!,"Print REPORT TOTALS (Y/N): Yes// ",X:999 S:X="" X="Y" S TOT=$$UP^XLFSTR($E(X_" ")) Q:'$T!(TOT[U) ;->
  1. I TOT="Y" D
  1. . S SUB="TOT",JOBN=$J
  1. . I '$D(^TMP(SUB,JOBN)) S SUB="KMPDH"
  1. . R !,"Include subtotals (Y/N): NO// ",WAY:999 QUIT:'$T!(WAY[U) ;->
  1. . S:WAY']"" WAY="N"
  1. . S WAY=$$UP^XLFSTR($E(WAY_" ")),WAY=$S(WAY="N":0,1:1)
  1. . S X=$$XTMPGBL^HLUCM004(0) I X]"" S (GBL,XTMPGBL)=X W !!,"Printing from ",XTMPGBL,"..."
  1. . D PRINT1
  1. Q
  1. ;
  1. SUB() ; What subscript holds the ^TMP(SUB,$J) data?
  1. N SUB
  1. I $D(^TMP("KMPDH",$J)) QUIT "KMPDH" ;->
  1. I $D(^TMP("TOT",$J)) QUIT "TOT" ;->
  1. R !!,"Enter subscript holding the ^TMP(TOTALS,$J) data: ",SUB:999 Q:SUB[U!(SUB']"") "" ;->
  1. Q SUB
  1. ;
  1. PRINT(SUB,JOBN,WAY) ; Print data in ^TMP(SUB,...) to screen
  1. ; WAY -- 0 = No totals
  1. ; 1 = Totals for every section
  1. N L1,L2,L3
  1. ;
  1. S WAY=$S($G(WAY)'>0:0,$G(WAY)=1:1,1:0)
  1. ;
  1. S:$G(JOBN)'>0 JOBN=$J
  1. I $G(SUB)']"" D QUIT ;->
  1. . W !!,"You must pass in the initial subscript and $JOB number..."
  1. . W !
  1. PRINT1 D PRINT1^HLUCM090
  1. ;
  1. S GBL=$NA(^TMP($J,"HLUCMSTORE","T"))
  1. S L1=0 F L2="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $D(@GBL@(L2)) S L1=1
  1. QUIT:'L1 ;->
  1. ;
  1. W !!,"Some entries were not included in the totals. There are 3 possible reasons"
  1. W !,"for entries being excluded: (1) The beginning time of a message or unit is"
  1. W !,"before the report's start time, (2) The number of seconds to transmit the"
  1. W !,"message is over 1799 seconds, and (3) The protocol or namespace doesn't meet"
  1. W !,"the search criteria."
  1. W !!,"Failure Reason",?30,"#Characters",?42,"#Msg/Units",?54,"#Seconds"
  1. W !,$$REPEAT^XLFSTR("=",IOM)
  1. ;
  1. F LAST="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $G(@GBL@(LAST))]"" Q
  1. ;
  1. S TYP="XXX",DATA=$G(@GBL@(TYP)) I DATA]"" D
  1. . D SHOW("Beginning time too early",DATA)
  1. . D SHOW("Excessive xmit time")
  1. . D SHOW("Prot/Nmsp mismatch","",1)
  1. S TYP="XXC",DATA=$G(@GBL@("XXC")) I DATA]"" D
  1. . D SHOW("Beginning time too early",DATA)
  1. . D SHOW("Excessive xmit time","",1)
  1. S TYP="XCX",DATA=$G(@GBL@("XCX")) I DATA]"" D
  1. . D SHOW("Beginning time too early",DATA)
  1. . D SHOW("Prot/Nmsp mismatch","",1)
  1. S TYP="XCC",DATA=$G(@GBL@("XCC")) I DATA]"" D
  1. . D SHOW("Beginning time too early",DATA,1)
  1. S TYP="CXX",DATA=$G(@GBL@("CXX")) I DATA]"" D
  1. . D SHOW("Excessive xmit time",DATA)
  1. . D SHOW("Prot/Nmsp mismatch","",1)
  1. S TYP="CXC",DATA=$G(@GBL@("CXC")) I DATA]"" D
  1. . D SHOW("Excessive xmit time",DATA,1)
  1. S TYP="CCX",DATA=$G(@GBL@("CCX")) I DATA]"" D
  1. . D SHOW("Prot/Nmsp mismatch",DATA,1)
  1. I L1!L2!L3 W !,$$REPEAT^XLFSTR("=",IOM),!,"Totals:",?30,$J(L1,7),?42,$J(L2,7),?54,$J(L3,7)
  1. ;
  1. Q
  1. ;
  1. SHOW(REA,DATA,LINE) ;
  1. ; LAST,TYP -- req
  1. S DATA=$G(DATA),LINE=$G(LINE)
  1. W !,REA
  1. I $G(DATA)]"" W ?30,$J($P(DATA,U),7),?42,$J($P(DATA,U,2),7),?54,$J($P(DATA,U,3),7)
  1. I $G(LINE),TYP'=LAST W !,$$REPEAT^XLFSTR("-",IOM)
  1. S L1=$G(L1)+$P(DATA,U),L2=$G(L2)+$P(DATA,U,2),L3=$G(L3)+$P(DATA,U,3)
  1. QUIT
  1. ;
  1. ADD(TL) ; Add to TOT...
  1. S $P(TOT,U)=$P(TOT,U)+$P(TL,U)
  1. S $P(TOT,U,2)=$P(TOT,U,2)+$P(TL,U,2)
  1. S $P(TOT,U,3)=$P(TOT,U,3)+$P(TL,U,3)
  1. Q
  1. ;
  1. OKPAR(PAR) ; Is namespace or protocol OK?
  1. S PAR=$G(PAR)
  1. I PAR=1!(PAR=2) QUIT 1 ;->
  1. I $$OK0CALL(PAR) QUIT 1 ;->
  1. QUIT ""
  1. ;
  1. OK0CALL(PAR) ; Correct 0^IEN or 0^NAME call format?
  1. I $E(PAR,1,2)="0^"&($E(PAR,3)]"") QUIT 1 ;->
  1. QUIT ""
  1. ;
  1. TYPETMO(IEN772) ; Is this TCP, Mail (via TCP), or Other?
  1. N D772,I773,MIEN
  1. ;
  1. ; RELATED MAILMAN MESSAGE field (0;5) in 772...
  1. S D772=$G(^HL(772,+IEN772,0)) ; Get node
  1. S MIEN=$P(D772,U,5) ; get Mailman IEN from field...
  1. I MIEN QUIT "M" ;-> Mailman via TCP
  1. ;
  1. ; There are rare instances when RELATED MAILMAN MESSAGE field is
  1. ; not filled in, but the LLP TYPE in 870 is Mailman. So, the next
  1. ; check is needed...
  1. ;
  1. ; Get related 870 and check it's LLP TYPE...
  1. I $P($G(^HLCS(870,+$$IEN870^HLUCM009(+IEN772),0)),U,3)=1 QUIT "M" ;->
  1. ;
  1. ; OK. Let's give up on proving this 772 entry a Mailman entry.
  1. ; But, is it TCP?
  1. ;
  1. ; Check if TCP by 773 link...
  1. S I773=$O(^HLMA("B",+IEN772,0))
  1. I I773>0 QUIT "T" ;->
  1. ;
  1. QUIT "U" ; Other...
  1. ;
  1. TYPEIO(IEN772) ; Is this Input or Output or Unknown?
  1. N D772,HLIO
  1. S D772=$G(^HL(772,+IEN772,0))
  1. S HLIO=$E($P(D772,U,4)_" ")
  1. QUIT $S("IO"[HLIO:HLIO,1:"U")
  1. ;
  1. PROTNMSP(IEN772) ; Return PROT~NMSP value to store in ^TMP.
  1. ; COND,IEN101,PNMSP -- req
  1. N CT,FAIL,PCKG,CTPROT,PCKG,PROT
  1. ;
  1. S IEN101=$G(IEN101),PNMSP=$G(PNMSP)
  1. ;
  1. ; ======================== PROTOCOL ============================
  1. ; Get actual protocol in IEN772 if not supposed to "lump"...
  1. S PROT=$S(IEN101'=2:$$GETPROT^HLUCM050(+IEN772),1:"ZZZ")
  1. ;
  1. ; Don't lose count if supposed to check everything...
  1. I IEN101=1!(IEN101=2) D
  1. . I PROT']"" S PROT="ZZZ" QUIT ;->
  1. . I IEN101=2 S PROT="ZZZ"
  1. ;
  1. ; Is the protocol countable? (Must also check namespace)
  1. S CTPROT=$$CTPROT^HLUCM003(PROT)
  1. ;
  1. ; ======================== NAMESPACE ============================
  1. ; Set package here and now...
  1. S PCKG=$S(PNMSP'=2:$$GETNMSP^HLUCM050(+IEN772),1:"ZZZ")
  1. ;
  1. I PNMSP=1!(PNMSP=2) D
  1. . I PCKG']"" S PCKG="ZZZ" QUIT ;->
  1. . I PNMSP=2 S PCKG="ZZZ"
  1. ;
  1. S CTPCKG=$$CTPCKG^HLUCM003(PCKG)
  1. ;
  1. ;
  1. ; Set up what should be returned...
  1. S PROT=$S(PROT=2:"ZZZ",1:PROT),PCKG=$S(PCKG=2:"ZZZ",1:PCKG)
  1. ; If MIXED make sure the ALL side of things is set to something
  1. ; so the ALL side doesn't squelch a SPECIFIC match...
  1. I $$MIXED D
  1. . I $G(PNMSP)=1!($G(PNMSP)=2) D
  1. . . QUIT:PROT]"" ;->
  1. . . QUIT:'CTPROT ;-> Not to be counted anyway...
  1. . . S PROT="ZZZ~0"
  1. . I $G(IEN101)=1!($G(IEN101)=2) D
  1. . . QUIT:PCKG]"" ;->
  1. . . QUIT:'CTPCKG ;-> Not to be counted anyway...
  1. . . S PCKG="ZZZ"
  1. I '$$MIXED,COND="EITHER" D
  1. . QUIT:$$ALL($G(PNMSP),$G(IEN101)) ;-> All 1s or 2s...
  1. . I NMSPTYPE'=1 D ; Asked specifically...
  1. . . QUIT:PROT]"" ;->
  1. . . S PROT="ZZZ~0"
  1. . I PROTYPE'=1 D ; Asked specifically...
  1. . . QUIT:PCKG]"" ;->
  1. . . S PCKG="ZZZ"
  1. ;
  1. ; If neither should be counted, don't...
  1. I 'CTPROT&('CTPCKG) QUIT U ;->
  1. ;
  1. ; Either namespace or protocol matches, or both match...
  1. ;
  1. ; If BOTH namespace and protocol are required to match, don't count if one isn't a match...
  1. I COND="BOTH" I 'CTPROT!('CTPCKG) QUIT U ;->
  1. ;
  1. ; If 1/2 & SPECIFIC (i.e., MIXED), then SPECIFIC trumps 1/2...
  1. ; (If SPECIFIC not matched, it is not counted)
  1. I $$MIXED D QUIT:FAIL U ;->
  1. . S FAIL=1
  1. . ; If ALL NMSPs to be counted, but specific PROT fails... BAD!
  1. . I $G(PNMSP)=1!($G(PNMSP)=2) QUIT:'CTPROT ;->
  1. . ; If ALL PROTs to be counted, but specific PCKG fails... BAD!
  1. . I $G(IEN101)=1!($G(IEN101)=2) QUIT:'CTPCKG ;->
  1. . S FAIL=0
  1. ;
  1. QUIT PROT_U_PCKG
  1. ;
  1. ALL(V1,V2) ; Are both 1 or 2?
  1. S V1=$G(V1),V2=$G(V2)
  1. QUIT:V1'=1&(V1'=2) "" ;->
  1. QUIT:V2'=1&(V2'=2) "" ;->
  1. QUIT 1
  1. ;
  1. MIXED() ; Is one 1/2 and the other SPECIFIC?
  1. N V3
  1. S V1=$G(PNMSP),V1=$S(V1]"":$S(V1=1!(V1=2):1,1:0),1:0)
  1. S V2=$G(IEN101),V2=$S(V2]"":$S(V2=1!(V2=2):1,1:0),1:0)
  1. S V1=$S(V1=1!(V1=2):1,1:0)
  1. S V2=$S(V2=1!(V2=2):1,1:0)
  1. S V3=V1+V2
  1. QUIT $S(V3=1:1,1:"")
  1. ;
  1. PROT101(IEN772) ; Return 101 information...
  1. N IEN,MIEN,NM
  1. ;
  1. ; Get normal protocol information
  1. S IEN=$P($G(^HL(772,IEN772,0)),U,10)
  1. S NM=$P($G(^ORD(101,+IEN,0)),U)
  1. ;
  1. ; Maybe this is a Mailman ptr only...
  1. I NM']"",IEN'>0 D
  1. . S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 ;->
  1. . S NM="XMB",IEN=9999999
  1. ;
  1. QUIT $S(NM]""!(IEN>0):NM_"~"_IEN,1:"")
  1. ;
  1. EOR ; HLUCM002 - HL7/Capacity Mgt API ;2/27/01 10:15