BLRSHDRP ;IHS/OIT/MKK - NON-MICRO STATE HEALTH DEPT REPORT PRINTER [ 07/22/2005 ]
;;5.2;LR;**1020**;Sep 13, 2005
;;
; Lab PSG gave permission to retrieve program from PIMC and distribute
; nationally. This is called by BLRSHDRC.
;
; Note that ^BLRSHDRD is the global name for the new dictionary that
; this routine depends upon: REPORTABLE LAB TESTS (# 90475).
; It has been distributed with this patch and number given to it by
; the IHS DBA.
;
; This the "printer" routine
;
; The following is code to prevent routine from being run by D ^BLRLRSEP.
EP ;
W !,$C(7),$C(7),$C(7),! ; Bell/Beep
W "Run from Label ONLY",!! ; Failsafe code
Q
;
PEP ; EP
NEW MAXPGLEN ; Max Page Length
NEW BLRQUFLG ; Queued Report Flag
;
I '$D(^TMP($J)) D Q
. W @IOF,"NO DATA TO REPORT",!!
. ;
. D PRESSRTN ; Press RETURN message
;
D ^XBCLS ; Clear screen and home cursor
D EN^DDIOL(.HEADERS) ; Write the Screen Header Lines
;
S %ZIS="Q"
D ^%ZIS ; "Open"
;
I POP>0 D Q
. W !,*7,*7,*7,"Device Open failed with Abnormal Exit."
. W !,?5,"Printing terminated.",!!
. D PRESSRTN
;
I IOM<132 D Q
. D ^%ZISC ; "Close"
. W !,*7,*7,*7,"Right Margin MUST BE 132."
. W ?5,"Device's Right Margin = ",IOM,!!
. W !,?5,"Printing terminated.",!!
. D PRESSRTN
;
I $D(IO("Q")) D Q ; Queue Report
. S BLRQUFLG="TRUE"
. S ZTRTN="LP^BLRSHDRP"
. S ZTSAVE("BLR*")=""
. S ZTSAVE("^TMP($J,")=""
. S ZTDESC="Reportable diseases"
. D ^%ZTLOAD
. K ZTSAVE,ZTDESC,ZTRTN,IO("Q")
. W !!,"End of Queued Report",!!
. D ^%ZISC
;
LP ;
I $G(BLRQUFLG)="TRUE" D ; If Queued report, need HEADER
. D SETHDRVS^BLRSHDRC($G(^TMP($J,"DIC4PTR")))
. D MAKEHDRS^BLRSHDRC ; Set Header variables
;
S MAXPGLEN=IOSL-10 ; Give white space at bottom of page
U IO ; Use device
;
S PEDT=$E(BLRENDT,4,5)_"/"_$E(BLRENDT,6,7)_"/"_$E(BLRENDT,2,3)
S PSDT=$E(BLRSDT,4,5)_"/"_$E(BLRSDT,6,7)_"/"_$E(BLRSDT,2,3)
S FOOTFLG=0,PG=1
S BLRTP=0
F S BLRTP=$O(^TMP($J,BLRTP)) Q:'BLRTP!(BLRTP'?.N) D
.S IENS=BLRTP_","
.S BLRTST=$$GET1^DIQ(90475,IENS,2) ; Reporting Name
.I FOOTFLG=1 D FOOTER
.I PG>1 W @IOF
.D RHEAD
.S LRDFN=""
.F S LRDFN=$O(^TMP($J,BLRTP,LRDFN)) Q:'LRDFN D
..S LRIDT=""
..F S LRIDT=$O(^TMP($J,BLRTP,LRDFN,LRIDT)) Q:'LRIDT D PRTIT
D FOOTER W @IOF
;
I $G(QUEFLAG)'="" Q ; If Queued report then Quit NOW
;
D ^%ZISC ; "Close"
;
Q
;
; REPORT LOOP
RLOOP1 D:FOOTFLG=1 FOOTER
W @IOF D RHEAD ; W !,"Reporting Test: "_DWBUG,!
S RPNM="" F II=0:0 S RPNM=$O(^UTILITY("CH",$J,DWBUG,RPNM)) Q:RPNM="" D RLOOP2
Q
;
RLOOP2 S RACC="" F III=0:0 S RACC=$O(^UTILITY("CH",$J,DWBUG,RPNM,RACC)) Q:RACC="" D PRTIT
Q
;
; PRINT LINES OF DATA
PRTIT ;
S Y=^TMP($J,BLRTP,LRDFN,LRIDT)
S Y1=^LR(LRDFN,"CH",LRIDT,0)
;
I ($Y+6)>MAXPGLEN D FOOTER W @IOF D RHEAD
;
W !!,$E($P(Y,U,1),1,28) ; PATIENT NAME
W ?30,$P(Y,U,2) ; HRN
W ?40,$P(Y,U,3) ; DOB
W ?54,$E($P(Y,U,4),1,1) ; SEX
W ?58,$P(Y1,U,6) ; ACCN
;
S IENS=LRIDT_","_LRDFN_","
S SPEC=$$GET1^DIQ(63.04,IENS,.05)
W ?74,$E(SPEC,1,12) ; SPECIMEN
;
S COLDT=$P(Y1,U,1) ; COLLECTION DATE
W ?88,$E(COLDT,4,5)_"/"_$E(COLDT,6,7)_"/"_$E(COLDT,2,3)
;
S VERDT=$P(Y1,U,3) ; VERIFY OR COMPLETE DATE
W ?98,$E(VERDT,4,5)_"/"_$E(VERDT,6,7)_"/"_$E(VERDT,2,3)
;
S PROV=$$GET1^DIQ(63.04,IENS,.1)
W ?108,$E(PROV,1,23) ; PROVIDER
;
W !,?5,$P(Y,U,5) ; PHONE
W ?30,$P(Y,U,6) ; STREET
W ?64,$P(Y,U,7) ; CITY
W ?84,$P(Y,U,8) ; STATE
W ?98,$P(Y,U,9) ; ZIP
W ?108,$E($P(Y1,U,11),1,23) ; LOCATION
;
W !,?5,"Result: ",$P(Y,U,11)
;
; start - vjm 4/14/2000
;W !?5,"Current COMMUNITY: ",$G(BLRXCOMM)
W !?5,"Current COMMUNITY: "
W $P(Y,U,10) ; CURRENT COMMUNITY
; end - vjm 4/14/2000
;
I $Y>MAXPGLEN D FOOTER W @IOF D RHEAD
;
Q
;
; REPORT HEADING
RHEAD ;
W !
W HEADER1
W !
W HEADER2
W !
W "From "_PSDT_" to "_PEDT
W ?53,"****** CONFIDENTIAL ******"
W ?98,"Printed: "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
W ?120,"Page: "_PG
W !!
W "Name"
W ?30,"ID#"
W ?40,"DOB"
W ?54,"Sex"
W ?58,"Lab #"
W ?74,"Sample"
W ?88,"Col Dt"
W ?98,"Cpl Dt"
W ?108,"Provider"
W !
W ?5,"Phone #"
W ?30,"Address"
W ?108,"Location"
;
; start - vjm 4/14/2000
W:$G(BLRGR) !?5,"Current Community"
; end - vjm 4/14/2000
;
; S M=$S($G(IOM):IOM,1:132)
; W ! F LI=0:1:M-1 W ?LI,"-"
W !
W $TR($J("",IOM)," ","-") ; Dashed line
; W !
S PG=PG+1
S FOOTFLG=1
I $G(BLRTST)'="" D Q
. W !,"Reporting Test: "_BLRTST
;
I $G(BRLTST)="" D
. W !,"Reporting Test: "_$G(^TMP($J,BLRTP))
;
Q
;
S PLG=MAXPGLEN-$Y F PP=1:1:PLG W !
W !,"________________________________________ ______________________"
W !," Medical Technologist Date",!
Q
;
; PRESS RETURN CODE
PRESSRTN ; EP
D ^XBFMK ; Kernel call cleans up FILEMAN vars
S DIR(0)="E",(X,Y)=""
S DIR("A")="Press RETURN to continue" ; Success or failure is irrelevant.
D ^DIR ; Used only prior to exit
Q
BLRSHDRP ;IHS/OIT/MKK - NON-MICRO STATE HEALTH DEPT REPORT PRINTER [ 07/22/2005 ]
+1 ;;5.2;LR;**1020**;Sep 13, 2005
+2 ;;
+3 ; Lab PSG gave permission to retrieve program from PIMC and distribute
+4 ; nationally. This is called by BLRSHDRC.
+5 ;
+6 ; Note that ^BLRSHDRD is the global name for the new dictionary that
+7 ; this routine depends upon: REPORTABLE LAB TESTS (# 90475).
+8 ; It has been distributed with this patch and number given to it by
+9 ; the IHS DBA.
+10 ;
+11 ; This the "printer" routine
+12 ;
+13 ; The following is code to prevent routine from being run by D ^BLRLRSEP.
EP ;
+1 ; Bell/Beep
WRITE !,$CHAR(7),$CHAR(7),$CHAR(7),!
+2 ; Failsafe code
WRITE "Run from Label ONLY",!!
+3 QUIT
+4 ;
PEP ; EP
+1 ; Max Page Length
NEW MAXPGLEN
+2 ; Queued Report Flag
NEW BLRQUFLG
+3 ;
+4 IF '$DATA(^TMP($JOB))
Begin DoDot:1
+5 WRITE @IOF,"NO DATA TO REPORT",!!
+6 ;
+7 ; Press RETURN message
DO PRESSRTN
End DoDot:1
QUIT
+8 ;
+9 ; Clear screen and home cursor
DO ^XBCLS
+10 ; Write the Screen Header Lines
DO EN^DDIOL(.HEADERS)
+11 ;
+12 SET %ZIS="Q"
+13 ; "Open"
DO ^%ZIS
+14 ;
+15 IF POP>0
Begin DoDot:1
+16 WRITE !,*7,*7,*7,"Device Open failed with Abnormal Exit."
+17 WRITE !,?5,"Printing terminated.",!!
+18 DO PRESSRTN
End DoDot:1
QUIT
+19 ;
+20 IF IOM<132
Begin DoDot:1
+21 ; "Close"
DO ^%ZISC
+22 WRITE !,*7,*7,*7,"Right Margin MUST BE 132."
+23 WRITE ?5,"Device's Right Margin = ",IOM,!!
+24 WRITE !,?5,"Printing terminated.",!!
+25 DO PRESSRTN
End DoDot:1
QUIT
+26 ;
+27 ; Queue Report
IF $DATA(IO("Q"))
Begin DoDot:1
+28 SET BLRQUFLG="TRUE"
+29 SET ZTRTN="LP^BLRSHDRP"
+30 SET ZTSAVE("BLR*")=""
+31 SET ZTSAVE("^TMP($J,")=""
+32 SET ZTDESC="Reportable diseases"
+33 DO ^%ZTLOAD
+34 KILL ZTSAVE,ZTDESC,ZTRTN,IO("Q")
+35 WRITE !!,"End of Queued Report",!!
+36 DO ^%ZISC
End DoDot:1
QUIT
+37 ;
LP ;
+1 ; If Queued report, need HEADER
IF $GET(BLRQUFLG)="TRUE"
Begin DoDot:1
+2 DO SETHDRVS^BLRSHDRC($GET(^TMP($JOB,"DIC4PTR")))
+3 ; Set Header variables
DO MAKEHDRS^BLRSHDRC
End DoDot:1
+4 ;
+5 ; Give white space at bottom of page
SET MAXPGLEN=IOSL-10
+6 ; Use device
USE IO
+7 ;
+8 SET PEDT=$EXTRACT(BLRENDT,4,5)_"/"_$EXTRACT(BLRENDT,6,7)_"/"_$EXTRACT(BLRENDT,2,3)
+9 SET PSDT=$EXTRACT(BLRSDT,4,5)_"/"_$EXTRACT(BLRSDT,6,7)_"/"_$EXTRACT(BLRSDT,2,3)
+10 SET FOOTFLG=0
SET PG=1
+11 SET BLRTP=0
+12 FOR
SET BLRTP=$ORDER(^TMP($JOB,BLRTP))
IF 'BLRTP!(BLRTP'?.N)
QUIT
Begin DoDot:1
+13 SET IENS=BLRTP_","
+14 ; Reporting Name
SET BLRTST=$$GET1^DIQ(90475,IENS,2)
+15 IF FOOTFLG=1
DO FOOTER
+16 IF PG>1
WRITE @IOF
+17 DO RHEAD
+18 SET LRDFN=""
+19 FOR
SET LRDFN=$ORDER(^TMP($JOB,BLRTP,LRDFN))
IF 'LRDFN
QUIT
Begin DoDot:2
+20 SET LRIDT=""
+21 FOR
SET LRIDT=$ORDER(^TMP($JOB,BLRTP,LRDFN,LRIDT))
IF 'LRIDT
QUIT
DO PRTIT
End DoDot:2
End DoDot:1
+22 DO FOOTER
WRITE @IOF
+23 ;
+24 ; If Queued report then Quit NOW
IF $GET(QUEFLAG)'=""
QUIT
+25 ;
+26 ; "Close"
DO ^%ZISC
+27 ;
+28 QUIT
+29 ;
+30 ; REPORT LOOP
RLOOP1 IF FOOTFLG=1
DO FOOTER
+1 ; W !,"Reporting Test: "_DWBUG,!
WRITE @IOF
DO RHEAD
+2 SET RPNM=""
FOR II=0:0
SET RPNM=$ORDER(^UTILITY("CH",$JOB,DWBUG,RPNM))
IF RPNM=""
QUIT
DO RLOOP2
+3 QUIT
+4 ;
RLOOP2 SET RACC=""
FOR III=0:0
SET RACC=$ORDER(^UTILITY("CH",$JOB,DWBUG,RPNM,RACC))
IF RACC=""
QUIT
DO PRTIT
+1 QUIT
+2 ;
+3 ; PRINT LINES OF DATA
PRTIT ;
+1 SET Y=^TMP($JOB,BLRTP,LRDFN,LRIDT)
+2 SET Y1=^LR(LRDFN,"CH",LRIDT,0)
+3 ;
+4 IF ($Y+6)>MAXPGLEN
DO FOOTER
WRITE @IOF
DO RHEAD
+5 ;
+6 ; PATIENT NAME
WRITE !!,$EXTRACT($PIECE(Y,U,1),1,28)
+7 ; HRN
WRITE ?30,$PIECE(Y,U,2)
+8 ; DOB
WRITE ?40,$PIECE(Y,U,3)
+9 ; SEX
WRITE ?54,$EXTRACT($PIECE(Y,U,4),1,1)
+10 ; ACCN
WRITE ?58,$PIECE(Y1,U,6)
+11 ;
+12 SET IENS=LRIDT_","_LRDFN_","
+13 SET SPEC=$$GET1^DIQ(63.04,IENS,.05)
+14 ; SPECIMEN
WRITE ?74,$EXTRACT(SPEC,1,12)
+15 ;
+16 ; COLLECTION DATE
SET COLDT=$PIECE(Y1,U,1)
+17 WRITE ?88,$EXTRACT(COLDT,4,5)_"/"_$EXTRACT(COLDT,6,7)_"/"_$EXTRACT(COLDT,2,3)
+18 ;
+19 ; VERIFY OR COMPLETE DATE
SET VERDT=$PIECE(Y1,U,3)
+20 WRITE ?98,$EXTRACT(VERDT,4,5)_"/"_$EXTRACT(VERDT,6,7)_"/"_$EXTRACT(VERDT,2,3)
+21 ;
+22 SET PROV=$$GET1^DIQ(63.04,IENS,.1)
+23 ; PROVIDER
WRITE ?108,$EXTRACT(PROV,1,23)
+24 ;
+25 ; PHONE
WRITE !,?5,$PIECE(Y,U,5)
+26 ; STREET
WRITE ?30,$PIECE(Y,U,6)
+27 ; CITY
WRITE ?64,$PIECE(Y,U,7)
+28 ; STATE
WRITE ?84,$PIECE(Y,U,8)
+29 ; ZIP
WRITE ?98,$PIECE(Y,U,9)
+30 ; LOCATION
WRITE ?108,$EXTRACT($PIECE(Y1,U,11),1,23)
+31 ;
+32 WRITE !,?5,"Result: ",$PIECE(Y,U,11)
+33 ;
+34 ; start - vjm 4/14/2000
+35 ;W !?5,"Current COMMUNITY: ",$G(BLRXCOMM)
+36 WRITE !?5,"Current COMMUNITY: "
+37 ; CURRENT COMMUNITY
WRITE $PIECE(Y,U,10)
+38 ; end - vjm 4/14/2000
+39 ;
+40 IF $Y>MAXPGLEN
DO FOOTER
WRITE @IOF
DO RHEAD
+41 ;
+42 QUIT
+43 ;
+44 ; REPORT HEADING
RHEAD ;
+1 WRITE !
+2 WRITE HEADER1
+3 WRITE !
+4 WRITE HEADER2
+5 WRITE !
+6 WRITE "From "_PSDT_" to "_PEDT
+7 WRITE ?53,"****** CONFIDENTIAL ******"
+8 WRITE ?98,"Printed: "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+9 WRITE ?120,"Page: "_PG
+10 WRITE !!
+11 WRITE "Name"
+12 WRITE ?30,"ID#"
+13 WRITE ?40,"DOB"
+14 WRITE ?54,"Sex"
+15 WRITE ?58,"Lab #"
+16 WRITE ?74,"Sample"
+17 WRITE ?88,"Col Dt"
+18 WRITE ?98,"Cpl Dt"
+19 WRITE ?108,"Provider"
+20 WRITE !
+21 WRITE ?5,"Phone #"
+22 WRITE ?30,"Address"
+23 WRITE ?108,"Location"
+24 ;
+25 ; start - vjm 4/14/2000
+26 IF $GET(BLRGR)
WRITE !?5,"Current Community"
+27 ; end - vjm 4/14/2000
+28 ;
+29 ; S M=$S($G(IOM):IOM,1:132)
+30 ; W ! F LI=0:1:M-1 W ?LI,"-"
+31 WRITE !
+32 ; Dashed line
WRITE $TRANSLATE($JUSTIFY("",IOM)," ","-")
+33 ; W !
+34 SET PG=PG+1
+35 SET FOOTFLG=1
+36 IF $GET(BLRTST)'=""
Begin DoDot:1
+37 WRITE !,"Reporting Test: "_BLRTST
End DoDot:1
QUIT
+38 ;
+39 IF $GET(BRLTST)=""
Begin DoDot:1
+40 WRITE !,"Reporting Test: "_$GET(^TMP($JOB,BLRTP))
End DoDot:1
+41 ;
+42 QUIT
+43 ;
+1 SET PLG=MAXPGLEN-$Y
FOR PP=1:1:PLG
WRITE !
+2 WRITE !,"________________________________________ ______________________"
+3 WRITE !," Medical Technologist Date",!
+4 QUIT
+5 ;
+6 ; PRESS RETURN CODE
PRESSRTN ; EP
+1 ; Kernel call cleans up FILEMAN vars
DO ^XBFMK
+2 SET DIR(0)="E"
SET (X,Y)=""
+3 ; Success or failure is irrelevant.
SET DIR("A")="Press RETURN to continue"
+4 ; Used only prior to exit
DO ^DIR
+5 QUIT
