- 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
