- 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
