BPC7OGMP ; IHS/OIT/MJL - Interim report rpc memo print 5/22/97 18:40 ;
;;1.5;BPC;;MAY 26, 2005
;;
;;5.2;LAB SERVICE;**187**;Sep 27, 1994
;
PRINT(OUTCNT) ;EP from LR7OGMC
N ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,HIGH,IDT,INTP,LINE,LOW,LRCW,PORDER,PRNTCODE,REFHIGH,REFLOW,SEX,SPEC,SUB,TESTNUM
N TESTSPEC,THER,THERHIGH,THERLOW,UNITS,VALUE,X,ZERO
; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
S AGE=$P(^TMP("BPC7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6)
S CDT=0 F S CDT=$O(^TMP("BPC7OG",$J,"TP",CDT)) Q:CDT="" D
.S IDT=9999999-CDT
.S ZERO=$S($D(^TMP("BPC7OG",$J,"TP",CDT))#2:^(CDT),1:"")
.I '$P(ZERO,U,3) Q
.S SPEC=+$P(ZERO,U,5)
.S DOC=$$NAME(+$P(ZERO,U,10))
.D SETLINE("",.OUTCNT)
.D SETLINE("Provider : "_DOC,.OUTCNT)
.S LINE=" Specimen: "_$P(^LAB(61,SPEC,0),U)_"."
.S ACC=$P(ZERO,U,6)
.S LINE=$$SETSTR^VALM1(" "_ACC,LINE,30,1+$L(ACC))
.D SETLINE(LINE,.OUTCNT)
.D SETLINE(" "_$$DD(CDT),.OUTCNT)
.D SETLINE(" Test name Result units Ref. range",.OUTCNT)
.S PORDER=0 F S PORDER=$O(^TMP("BPC7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0 S DATA=^(PORDER) D
..I $P(DATA,U,7)="" Q
..S TESTNUM=+DATA,PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7)
..S LINE=" "_$S($L($P(DATA,U,2))>20:$P(DATA,U,3),1:$P(DATA,U,2))
..S LINE=$$SETSTR^VALM1("",LINE,28,0)
..I PRNTCODE="" S LINE=LINE_$J(X,8)
..E S @("VALUE="_PRNTCODE),LINE=LINE_VALUE
..S LINE=LINE_" "_FLAG
..S TESTSPEC=$S($D(^LAB(60,TESTNUM,1,SPEC,0)):^(0),1:"")
..I '$L(TESTSPEC) D SETLINE(LINE,.OUTCNT) Q
..S REFLOW=$P(TESTSPEC,U,2),REFHIGH=$P(TESTSPEC,U,3),THERLOW=$P(TESTSPEC,U,11),THERHIGH=$P(TESTSPEC,U,12),UNITS=$P(TESTSPEC,U,7)
..S THER=$S($L(THERHIGH):1,$L(THERLOW):1,1:0)
..S LOW=$S(THER:THERLOW,1:REFLOW)
..S HIGH=$S(THER:THERHIGH,1:REFHIGH)
..S @("LOW="_$S($L(LOW):LOW,1:""""""))
..S @("HIGH="_$S($L(HIGH):HIGH,1:""""""))
..S LINE=$$SETSTR^VALM1(" "_UNITS,LINE,39,2+$L(UNITS))
..S LINE=$$SETSTR^VALM1($J(LOW,4)_$S($L(HIGH):" - "_$J(HIGH,4),1:""),LINE,52,4+$S($L(HIGH):7,1:0))
..S LINE=$$SETSTR^VALM1($S(THER:"(Ther. range)",1:""),LINE,64,$S(THER:13,1:0))
..D SETLINE(LINE,.OUTCNT)
..I $O(^TMP("BPC7OG",$J,"TP",CDT,PORDER,0))>0 D
...S INTP=0 F S INTP=+$O(^TMP("BPC7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1 D SETLINE(" Eval: "_^(INTP),.OUTCNT)
.I $D(^TMP("BPC7OG",$J,"TP",CDT,"C")) D
..S LINE="Comment: "
..S CMNT=0 F S CMNT=+$O(^TMP("BPC7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1 S LINE=LINE_^(CMNT) D
...D SETLINE(LINE,.OUTCNT)
...I $O(^TMP("BPC7OG",$J,"TP",CDT,"C",CMNT)) S LINE=" "
.D SETLINE("===============================================================================",.OUTCNT)
Q
;
SETLINE(LINE,CNT) ;
S ^TMP("BPC7OGX",$J,"OUTPUT",CNT)=LINE
S CNT=CNT+1
Q
;
NAME(X) ;EP $$(#) -> name
N LRDOC
D DOC^LRX
Q LRDOC
;
DD(Y) ; $$(date/time) -> date/time format
D DD^LRX
Q Y
BPC7OGMP ; IHS/OIT/MJL - Interim report rpc memo print 5/22/97 18:40 ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;;
+3 ;;5.2;LAB SERVICE;**187**;Sep 27, 1994
+4 ;
PRINT(OUTCNT) ;EP from LR7OGMC
+1 NEW ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,HIGH,IDT,INTP,LINE,LOW,LRCW,PORDER,PRNTCODE,REFHIGH,REFLOW,SEX,SPEC,SUB,TESTNUM
+2 NEW TESTSPEC,THER,THERHIGH,THERLOW,UNITS,VALUE,X,ZERO
+3 ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
+4 SET AGE=$PIECE(^TMP("BPC7OG",$JOB,"G"),U,4)
SET SEX=$PIECE(^("G"),U,5)
SET LRCW=$PIECE(^("G"),U,6)
+5 SET CDT=0
FOR
SET CDT=$ORDER(^TMP("BPC7OG",$JOB,"TP",CDT))
IF CDT=""
QUIT
Begin DoDot:1
+6 SET IDT=9999999-CDT
+7 SET ZERO=$SELECT($DATA(^TMP("BPC7OG",$JOB,"TP",CDT))#2:^(CDT),1:"")
+8 IF '$PIECE(ZERO,U,3)
QUIT
+9 SET SPEC=+$PIECE(ZERO,U,5)
+10 SET DOC=$$NAME(+$PIECE(ZERO,U,10))
+11 DO SETLINE("",.OUTCNT)
+12 DO SETLINE("Provider : "_DOC,.OUTCNT)
+13 SET LINE=" Specimen: "_$PIECE(^LAB(61,SPEC,0),U)_"."
+14 SET ACC=$PIECE(ZERO,U,6)
+15 SET LINE=$$SETSTR^VALM1(" "_ACC,LINE,30,1+$LENGTH(ACC))
+16 DO SETLINE(LINE,.OUTCNT)
+17 DO SETLINE(" "_$$DD(CDT),.OUTCNT)
+18 DO SETLINE(" Test name Result units Ref. range",.OUTCNT)
+19 SET PORDER=0
FOR
SET PORDER=$ORDER(^TMP("BPC7OG",$JOB,"TP",CDT,PORDER))
IF PORDER'>0
QUIT
SET DATA=^(PORDER)
Begin DoDot:2
+20 IF $PIECE(DATA,U,7)=""
QUIT
+21 SET TESTNUM=+DATA
SET PRNTCODE=$PIECE(DATA,U,5)
SET SUB=$PIECE(DATA,U,6)
SET FLAG=$PIECE(DATA,U,8)
SET X=$PIECE(DATA,U,7)
+22 SET LINE=" "_$SELECT($LENGTH($PIECE(DATA,U,2))>20:$PIECE(DATA,U,3),1:$PIECE(DATA,U,2))
+23 SET LINE=$$SETSTR^VALM1("",LINE,28,0)
+24 IF PRNTCODE=""
SET LINE=LINE_$JUSTIFY(X,8)
+25 IF '$TEST
SET @("VALUE="_PRNTCODE)
SET LINE=LINE_VALUE
+26 SET LINE=LINE_" "_FLAG
+27 SET TESTSPEC=$SELECT($DATA(^LAB(60,TESTNUM,1,SPEC,0)):^(0),1:"")
+28 IF '$LENGTH(TESTSPEC)
DO SETLINE(LINE,.OUTCNT)
QUIT
+29 SET REFLOW=$PIECE(TESTSPEC,U,2)
SET REFHIGH=$PIECE(TESTSPEC,U,3)
SET THERLOW=$PIECE(TESTSPEC,U,11)
SET THERHIGH=$PIECE(TESTSPEC,U,12)
SET UNITS=$PIECE(TESTSPEC,U,7)
+30 SET THER=$SELECT($LENGTH(THERHIGH):1,$LENGTH(THERLOW):1,1:0)
+31 SET LOW=$SELECT(THER:THERLOW,1:REFLOW)
+32 SET HIGH=$SELECT(THER:THERHIGH,1:REFHIGH)
+33 SET @("LOW="_$SELECT($LENGTH(LOW):LOW,1:""""""))
+34 SET @("HIGH="_$SELECT($LENGTH(HIGH):HIGH,1:""""""))
+35 SET LINE=$$SETSTR^VALM1(" "_UNITS,LINE,39,2+$LENGTH(UNITS))
+36 SET LINE=$$SETSTR^VALM1($JUSTIFY(LOW,4)_$SELECT($LENGTH(HIGH):" - "_$JUSTIFY(HIGH,4),1:""),LINE,52,4+$SELECT($LENGTH(HIGH):7,1:0))
+37 SET LINE=$$SETSTR^VALM1($SELECT(THER:"(Ther. range)",1:""),LINE,64,$SELECT(THER:13,1:0))
+38 DO SETLINE(LINE,.OUTCNT)
+39 IF $ORDER(^TMP("BPC7OG",$JOB,"TP",CDT,PORDER,0))>0
Begin DoDot:3
+40 SET INTP=0
FOR
SET INTP=+$ORDER(^TMP("BPC7OG",$JOB,"TP",CDT,PORDER,INTP))
IF INTP<1
QUIT
DO SETLINE(" Eval: "_^(INTP),.OUTCNT)
End DoDot:3
End DoDot:2
+41 IF $DATA(^TMP("BPC7OG",$JOB,"TP",CDT,"C"))
Begin DoDot:2
+42 SET LINE="Comment: "
+43 SET CMNT=0
FOR
SET CMNT=+$ORDER(^TMP("BPC7OG",$JOB,"TP",CDT,"C",CMNT))
IF CMNT<1
QUIT
SET LINE=LINE_^(CMNT)
Begin DoDot:3
+44 DO SETLINE(LINE,.OUTCNT)
+45 IF $ORDER(^TMP("BPC7OG",$JOB,"TP",CDT,"C",CMNT))
SET LINE=" "
End DoDot:3
End DoDot:2
+46 DO SETLINE("===============================================================================",.OUTCNT)
End DoDot:1
+47 QUIT
+48 ;
SETLINE(LINE,CNT) ;
+1 SET ^TMP("BPC7OGX",$JOB,"OUTPUT",CNT)=LINE
+2 SET CNT=CNT+1
+3 QUIT
+4 ;
NAME(X) ;EP $$(#) -> name
+1 NEW LRDOC
+2 DO DOC^LRX
+3 QUIT LRDOC
+4 ;
DD(Y) ; $$(date/time) -> date/time format
+1 DO DD^LRX
+2 QUIT Y
