BTPWTIUP ;VNGT/HS/ALA-Print APIs ; 15 Jun 2010 4:33 PM
;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011
;
;
REM(NDATA,FAKE) ; EP -- BTPW GET REMOTE DEVICES
NEW UID,II,RESULT,MSG,DVN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S NDATA=$NA(^TMP("BTPWTIUP",UID))
K @NDATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWTIUP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;Header
S @NDATA@(II)="T00030HIDE_TIUIO^T00050DEVICE_NAME^T00050LOCATION^T00005MARGIN"_$C(30)
;
D DEVICE^CIAVUTIO(.DATA,"",-1)
S DVN=0
F S DVN=$O(DATA(DVN)) Q:DVN="" D
. S II=II+1,@NDATA@(II)=$P(DATA(DVN),U,1,4)_$C(30)
;
DONE ;
S II=II+1,@NDATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
S II=II+1,@NDATA@(II)=$C(31)
Q
;
PRW(DATA,TIUDA,TIUIO) ; EP -- BTPW PRINT TO RPMS DEVICE
; Input Parameters
; TIUDA=document IEN
; TIUIO=device name
;
NEW UID,II,RESULT,MSG,HDR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWPRWN",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWTIUP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="I00010RESULT^T01024MSG"
S @DATA@(II)=HDR_$C(30)
D RPC^TIUPD(.RESULT,TIUDA,TIUIO,2,"") ; Print to a RPMS printer
I $P(RESULT,U,1)=1 S RESULT=-1,MSG=$P(RESULT,U,2)
I $P(RESULT,U,1)=0 S RESULT=1,MSG=$P(RESULT,U,2)
S II=II+1,@DATA@(II)=RESULT_U_MSG_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
RPC(DATA,TIUFLAG,TIUIO,TIUWIN,TLIST) ; EP -- BTPW PRINT CMET TIU
; Input Parameters
; TLIST=document IENs separate by $C(28)
; TIUIO=device name
; TIUFLAG 1=Chart Copy 2=Work Copy 3=Patient copy
; TIUWIN 1=Windows printer 0=RPMS printer
; TIUIO = If RPMS printer, DEVICE_NAME from BTPW GET REMOTE DEVICES
;
NEW UID,II,TIUDA,TDATA,LIST
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J),II=0
S DATA=$NA(^TMP("BTPWPRPV",UID)),TDATA=$NA(^TMP("BTPWPRX",UID))
K @DATA,@TDATA
;
I $D(TLIST)>1 D
. S LIST="",BN=""
. F S BN=$O(TLIST(BN)) Q:BN="" S LIST=LIST_TLIST(BN)
. K TLIST S TLIST=LIST
;
I TIUWIN D HDR
;
F BTP=1:1 S TIUDA=$P(TLIST,$C(28),BTP) Q:TIUDA="" D
. I 'TIUWIN D
.. S ZTIO=TIUIO,ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
.. S ZTDESC="Patient Copy PRINT for "_$$GET1^DIQ(8925,TIUDA_",",.01,"E")
.. S ZTRTN="PRT^BTPWTIUP",ZTSAVE("TLIST")="",ZTSAVE("TIUFLAG")=""
.. S ZTSAVE("DUZ(")=""
.. D ^%ZTLOAD
.. S @DATA@(II)="I00010RESULT"_$C(30)
.. S II=II+1,@DATA@(II)=1_$C(30)
.. K ZTSAVE,ZTIO,ZTDTH,ZTDESC,ZTRTN
. I TIUWIN D
.. NEW %,%H,%I,BJ,BN,BTI,BTP,DFN,FBN,HRCN,HSTEXT,I,LBN,NBN,QFL,VAERR
.. NEW TIUD0,TIUD13,TIUD15,TIUDATE,TIUIDDAD,TIUPFHDR,TIUPFNBR,TBN
.. NEW TIUPGRP,TIUPMTHD,TIUSIG,TIUTNM,TIUTYPE,BW,DRAFT,EBN,NLR,NPG
.. K ^TMP("TIUPR",$J)
.. S BTI=0
.. D PRM
.. I $$TMPFL^BQIUL1("W",UID,DFN) Q
.. U IO X TIUPMTHD
.. U IO W $C(23)
.. ;
.. I $$TMPFL^BQIUL1("C") Q
.. I $$TMPFL^BQIUL1("R",UID,DFN) Q
.. ;
.. F U IO R HSTEXT:.1 Q:HSTEXT[$C(23) D
... S HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^"),HSTEXT=$$CTRL^BQIUL1(HSTEXT)
... I HSTEXT="" S HSTEXT=" "
... S BTI=BTI+1,@TDATA@(BTI)=HSTEXT_$C(13)_$C(10)
.. ;
.. S NBN=0,LBN=$O(@TDATA@(""),-1)+1,TBN=LBN
.. S NPG=TBN\66,NLR=TBN#66 S:NLR>2 NPG=NPG+1
.. F BW=0:1:(NPG-1) D
... S BN=$S(BW=0:0,1:(BW*66)+1)
... S EBN=$S(BW=0:66,1:(BW*66)+66)
... S QFL=0
... F S BN=$O(@TDATA@(BN)) Q:'BN!(QFL) D
.... I @TDATA@(BN)["SUBJECT:",BW=0 S NBN=BN,QFL=1 Q
.... I @TDATA@(BN)["** CONTINUED FROM PREVIOUS",BW'=0 S NBN=BN,QFL=1
... S BN=EBN,QFL=0
... F S BN=$O(@TDATA@(BN),-1) Q:'BN!(QFL) D
.... I @TDATA@(BN)["** THIS NOTE CONTINUED ON NEXT PAGE",BW<NPG S FBN=BN,QFL=1 Q
.... I @TDATA@(BN)["----------",BW=(NPG-1) S FBN=(BN-6),QFL=1
... S FBN=(FBN-1),DRAFT=0
... F BJ=NBN+1:1:FBN D
.... I @TDATA@(BJ)["**DRAFT COPY" S DRAFT=1 Q
.... I DRAFT,@TDATA@(BJ)["Author: " Q
.... S II=II+1,@DATA@(II)=@TDATA@(BJ)
... S II=II+1,@DATA@(II)=$C(12)
.. I $$TMPFL^BQIUL1("C") Q
.. I $$TMPFL^BQIUL1("D",UID,DFN) Q
. S II=II+1,@DATA@(II)=$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
;
Q
;
PRM ; Get Print Method for the document
S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD13=$G(^TIU(8925,+TIUDA,13))
S TIUD15=$G(^TIU(8925,+TIUDA,15)),TIUTYPE=+TIUD0,TIUFLAG=+$G(TIUFLAG)
S TIUDATE=$S(+TIUD15>0:+TIUD15,+TIUD13>0:+TIUD13,1:+$G(DT))
I '+TIUTYPE Q
S DFN=+$P(TIUD0,U,2)
S TIUTNM=$$PNAME^TIULC1(+TIUTYPE)
S TIUPMTHD=$$PRNTMTHD^TIULG(+TIUTYPE,TIUDA)
S TIUPGRP=$$PRNTGRP^TIULG(+TIUTYPE,TIUDA)
S TIUPFHDR=$$PRNTHDR^TIULG(+TIUTYPE,TIUDA)
S TIUPFNBR=$$PRNTNBR^TIULG(+TIUTYPE,TIUDA)
I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6)
S TIUIDDAD=$$HASIDDAD^TIUGBR(TIUDA)
I TIUIDDAD S TIUDA=TIUIDDAD
I $G(TIUPMTHD)]"",+$G(TIUPGRP),($G(TIUPFHDR)]""),($G(TIUPFNBR)]"") D
. S ^TMP("TIUPR",$J,$G(TIUPGRP)_"$"_$G(TIUPFHDR)_";"_DFN,1,TIUDA)=$G(TIUPFNBR)
E S ^TMP("TIUPR",$J,DFN,1,TIUDA)=""
Q
;
HDR ;
S @DATA@(II)="T02048REPORT_TEXT"_$C(30)
Q
;
PRT ;EP - Print to a RPMS printer
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S TDATA=$NA(^TMP("BTPWPRX",UID)) K @TDATA
F BTP=1:1 S TIUDA=$P(TLIST,$C(28),BTP) Q:TIUDA="" D
. NEW %,%H,%I,BJ,BN,BTI,BTP,DFN,FBN,HRCN,HSTEXT,I,LBN,NBN,QFL,VAERR
. NEW TIUD0,TIUD13,TIUD15,TIUDATE,TIUIDDAD,TIUPFHDR,TIUPFNBR
. NEW TIUPGRP,TIUPMTHD,TIUSIG,TIUTNM,TIUTYPE
. K ^TMP("TIUPR",$J)
. S BTI=0
. D PRM
. NEW IO
. D
.. I $$TMPFL^BQIUL1("W",UID,DFN) Q
.. U IO X TIUPMTHD
.. U IO W $C(9)
.. ;
.. I $$TMPFL^BQIUL1("C") Q
.. I $$TMPFL^BQIUL1("R",UID,DFN) Q
.. ;
.. F U IO R HSTEXT:.1 Q:HSTEXT[$C(9) D
... S HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^"),HSTEXT=$$CTRL^BQIUL1(HSTEXT)
... I HSTEXT="" S HSTEXT=" "
... S BTI=BTI+1,@TDATA@(BTI)=HSTEXT
.. ;
.. I $$TMPFL^BQIUL1("C") Q
.. I $$TMPFL^BQIUL1("D",UID,DFN) Q
. S BN=0,QFL=0 F S BN=$O(@TDATA@(BN)) Q:'BN!(QFL) I @TDATA@(BN)["SUBJECT:" S NBN=BN,QFL=1
. S BN=NBN,QFL=0 F S BN=$O(@TDATA@(BN)) Q:'BN!(QFL) I @TDATA@(BN)["----------" S LBN=BN,QFL=1
. S FBN=LBN-1
. F BJ=NBN+1:1:$S(FBN<66:FBN,1:62) U IO W !,@TDATA@(BJ)
. I FBN>65 D
.. W @IOF
.. F BJ=63:1:FBN U IO W !,@TDATA@(BJ)
. W @IOF
K @TDATA
Q
BTPWTIUP ;VNGT/HS/ALA-Print APIs ; 15 Jun 2010 4:33 PM
+1 ;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011
+2 ;
+3 ;
REM(NDATA,FAKE) ; EP -- BTPW GET REMOTE DEVICES
+1 NEW UID,II,RESULT,MSG,DVN
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET NDATA=$NAME(^TMP("BTPWTIUP",UID))
+4 KILL @NDATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWTIUP D UNWIND^%ZTER"
+8 ;
+9 ;Header
+10 SET @NDATA@(II)="T00030HIDE_TIUIO^T00050DEVICE_NAME^T00050LOCATION^T00005MARGIN"_$CHAR(30)
+11 ;
+12 DO DEVICE^CIAVUTIO(.DATA,"",-1)
+13 SET DVN=0
+14 FOR
SET DVN=$ORDER(DATA(DVN))
IF DVN=""
QUIT
Begin DoDot:1
+15 SET II=II+1
SET @NDATA@(II)=$PIECE(DATA(DVN),U,1,4)_$CHAR(30)
End DoDot:1
+16 ;
DONE ;
+1 SET II=II+1
SET @NDATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 SET II=II+1
SET @NDATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
PRW(DATA,TIUDA,TIUIO) ; EP -- BTPW PRINT TO RPMS DEVICE
+1 ; Input Parameters
+2 ; TIUDA=document IEN
+3 ; TIUIO=device name
+4 ;
+5 NEW UID,II,RESULT,MSG,HDR
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BTPWPRWN",UID))
+8 KILL @DATA
+9 ;
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWTIUP D UNWIND^%ZTER"
+12 ;
+13 SET HDR="I00010RESULT^T01024MSG"
+14 SET @DATA@(II)=HDR_$CHAR(30)
+15 ; Print to a RPMS printer
DO RPC^TIUPD(.RESULT,TIUDA,TIUIO,2,"")
+16 IF $PIECE(RESULT,U,1)=1
SET RESULT=-1
SET MSG=$PIECE(RESULT,U,2)
+17 IF $PIECE(RESULT,U,1)=0
SET RESULT=1
SET MSG=$PIECE(RESULT,U,2)
+18 SET II=II+1
SET @DATA@(II)=RESULT_U_MSG_$CHAR(30)
+19 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+20 QUIT
+21 ;
RPC(DATA,TIUFLAG,TIUIO,TIUWIN,TLIST) ; EP -- BTPW PRINT CMET TIU
+1 ; Input Parameters
+2 ; TLIST=document IENs separate by $C(28)
+3 ; TIUIO=device name
+4 ; TIUFLAG 1=Chart Copy 2=Work Copy 3=Patient copy
+5 ; TIUWIN 1=Windows printer 0=RPMS printer
+6 ; TIUIO = If RPMS printer, DEVICE_NAME from BTPW GET REMOTE DEVICES
+7 ;
+8 NEW UID,II,TIUDA,TDATA,LIST
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
SET II=0
+10 SET DATA=$NAME(^TMP("BTPWPRPV",UID))
SET TDATA=$NAME(^TMP("BTPWPRX",UID))
+11 KILL @DATA,@TDATA
+12 ;
+13 IF $DATA(TLIST)>1
Begin DoDot:1
+14 SET LIST=""
SET BN=""
+15 FOR
SET BN=$ORDER(TLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_TLIST(BN)
+16 KILL TLIST
SET TLIST=LIST
End DoDot:1
+17 ;
+18 IF TIUWIN
DO HDR
+19 ;
+20 FOR BTP=1:1
SET TIUDA=$PIECE(TLIST,$CHAR(28),BTP)
IF TIUDA=""
QUIT
Begin DoDot:1
+21 IF 'TIUWIN
Begin DoDot:2
+22 SET ZTIO=TIUIO
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),,,3)
+23 SET ZTDESC="Patient Copy PRINT for "_$$GET1^DIQ(8925,TIUDA_",",.01,"E")
+24 SET ZTRTN="PRT^BTPWTIUP"
SET ZTSAVE("TLIST")=""
SET ZTSAVE("TIUFLAG")=""
+25 SET ZTSAVE("DUZ(")=""
+26 DO ^%ZTLOAD
+27 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+28 SET II=II+1
SET @DATA@(II)=1_$CHAR(30)
+29 KILL ZTSAVE,ZTIO,ZTDTH,ZTDESC,ZTRTN
End DoDot:2
+30 IF TIUWIN
Begin DoDot:2
+31 NEW %,%H,%I,BJ,BN,BTI,BTP,DFN,FBN,HRCN,HSTEXT,I,LBN,NBN,QFL,VAERR
+32 NEW TIUD0,TIUD13,TIUD15,TIUDATE,TIUIDDAD,TIUPFHDR,TIUPFNBR,TBN
+33 NEW TIUPGRP,TIUPMTHD,TIUSIG,TIUTNM,TIUTYPE,BW,DRAFT,EBN,NLR,NPG
+34 KILL ^TMP("TIUPR",$JOB)
+35 SET BTI=0
+36 DO PRM
+37 IF $$TMPFL^BQIUL1("W",UID,DFN)
QUIT
+38 USE IO
XECUTE TIUPMTHD
+39 USE IO
WRITE $CHAR(23)
+40 ;
+41 IF $$TMPFL^BQIUL1("C")
QUIT
+42 IF $$TMPFL^BQIUL1("R",UID,DFN)
QUIT
+43 ;
+44 FOR
USE IO
READ HSTEXT:.1
IF HSTEXT[$CHAR(23)
QUIT
Begin DoDot:3
+45 SET HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
SET HSTEXT=$$CTRL^BQIUL1(HSTEXT)
+46 IF HSTEXT=""
SET HSTEXT=" "
+47 SET BTI=BTI+1
SET @TDATA@(BTI)=HSTEXT_$CHAR(13)_$CHAR(10)
End DoDot:3
+48 ;
+49 SET NBN=0
SET LBN=$ORDER(@TDATA@(""),-1)+1
SET TBN=LBN
+50 SET NPG=TBN\66
SET NLR=TBN#66
IF NLR>2
SET NPG=NPG+1
+51 FOR BW=0:1:(NPG-1)
Begin DoDot:3
+52 SET BN=$SELECT(BW=0:0,1:(BW*66)+1)
+53 SET EBN=$SELECT(BW=0:66,1:(BW*66)+66)
+54 SET QFL=0
+55 FOR
SET BN=$ORDER(@TDATA@(BN))
IF 'BN!(QFL)
QUIT
Begin DoDot:4
+56 IF @TDATA@(BN)["SUBJECT:"
IF BW=0
SET NBN=BN
SET QFL=1
QUIT
+57 IF @TDATA@(BN)["** CONTINUED FROM PREVIOUS"
IF BW'=0
SET NBN=BN
SET QFL=1
End DoDot:4
+58 SET BN=EBN
SET QFL=0
+59 FOR
SET BN=$ORDER(@TDATA@(BN),-1)
IF 'BN!(QFL)
QUIT
Begin DoDot:4
+60 IF @TDATA@(BN)["** THIS NOTE CONTINUED ON NEXT PAGE"
IF BW<NPG
SET FBN=BN
SET QFL=1
QUIT
+61 IF @TDATA@(BN)["----------"
IF BW=(NPG-1)
SET FBN=(BN-6)
SET QFL=1
End DoDot:4
+62 SET FBN=(FBN-1)
SET DRAFT=0
+63 FOR BJ=NBN+1:1:FBN
Begin DoDot:4
+64 IF @TDATA@(BJ)["**DRAFT COPY"
SET DRAFT=1
QUIT
+65 IF DRAFT
IF @TDATA@(BJ)["Author: "
QUIT
+66 SET II=II+1
SET @DATA@(II)=@TDATA@(BJ)
End DoDot:4
+67 SET II=II+1
SET @DATA@(II)=$CHAR(12)
End DoDot:3
+68 IF $$TMPFL^BQIUL1("C")
QUIT
+69 IF $$TMPFL^BQIUL1("D",UID,DFN)
QUIT
End DoDot:2
+70 SET II=II+1
SET @DATA@(II)=$CHAR(30)
End DoDot:1
+71 ;
+72 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+73 ;
+74 QUIT
+75 ;
PRM ; Get Print Method for the document
+1 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUD13=$GET(^TIU(8925,+TIUDA,13))
+2 SET TIUD15=$GET(^TIU(8925,+TIUDA,15))
SET TIUTYPE=+TIUD0
SET TIUFLAG=+$GET(TIUFLAG)
+3 SET TIUDATE=$SELECT(+TIUD15>0:+TIUD15,+TIUD13>0:+TIUD13,1:+$GET(DT))
+4 IF '+TIUTYPE
QUIT
+5 SET DFN=+$PIECE(TIUD0,U,2)
+6 SET TIUTNM=$$PNAME^TIULC1(+TIUTYPE)
+7 SET TIUPMTHD=$$PRNTMTHD^TIULG(+TIUTYPE,TIUDA)
+8 SET TIUPGRP=$$PRNTGRP^TIULG(+TIUTYPE,TIUDA)
+9 SET TIUPFHDR=$$PRNTHDR^TIULG(+TIUTYPE,TIUDA)
+10 SET TIUPFNBR=$$PRNTNBR^TIULG(+TIUTYPE,TIUDA)
+11 IF +$$ISADDNDM^TIULC1(TIUDA)
SET TIUDA=+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,6)
+12 SET TIUIDDAD=$$HASIDDAD^TIUGBR(TIUDA)
+13 IF TIUIDDAD
SET TIUDA=TIUIDDAD
+14 IF $GET(TIUPMTHD)]""
IF +$GET(TIUPGRP)
IF ($GET(TIUPFHDR)]"")
IF ($GET(TIUPFNBR)]"")
Begin DoDot:1
+15 SET ^TMP("TIUPR",$JOB,$GET(TIUPGRP)_"$"_$GET(TIUPFHDR)_";"_DFN,1,TIUDA)=$GET(TIUPFNBR)
End DoDot:1
+16 IF '$TEST
SET ^TMP("TIUPR",$JOB,DFN,1,TIUDA)=""
+17 QUIT
+18 ;
HDR ;
+1 SET @DATA@(II)="T02048REPORT_TEXT"_$CHAR(30)
+2 QUIT
+3 ;
PRT ;EP - Print to a RPMS printer
+1 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+2 SET TDATA=$NAME(^TMP("BTPWPRX",UID))
KILL @TDATA
+3 FOR BTP=1:1
SET TIUDA=$PIECE(TLIST,$CHAR(28),BTP)
IF TIUDA=""
QUIT
Begin DoDot:1
+4 NEW %,%H,%I,BJ,BN,BTI,BTP,DFN,FBN,HRCN,HSTEXT,I,LBN,NBN,QFL,VAERR
+5 NEW TIUD0,TIUD13,TIUD15,TIUDATE,TIUIDDAD,TIUPFHDR,TIUPFNBR
+6 NEW TIUPGRP,TIUPMTHD,TIUSIG,TIUTNM,TIUTYPE
+7 KILL ^TMP("TIUPR",$JOB)
+8 SET BTI=0
+9 DO PRM
+10 NEW IO
+11 Begin DoDot:2
+12 IF $$TMPFL^BQIUL1("W",UID,DFN)
QUIT
+13 USE IO
XECUTE TIUPMTHD
+14 USE IO
WRITE $CHAR(9)
+15 ;
+16 IF $$TMPFL^BQIUL1("C")
QUIT
+17 IF $$TMPFL^BQIUL1("R",UID,DFN)
QUIT
+18 ;
+19 FOR
USE IO
READ HSTEXT:.1
IF HSTEXT[$CHAR(9)
QUIT
Begin DoDot:3
+20 SET HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
SET HSTEXT=$$CTRL^BQIUL1(HSTEXT)
+21 IF HSTEXT=""
SET HSTEXT=" "
+22 SET BTI=BTI+1
SET @TDATA@(BTI)=HSTEXT
End DoDot:3
+23 ;
+24 IF $$TMPFL^BQIUL1("C")
QUIT
+25 IF $$TMPFL^BQIUL1("D",UID,DFN)
QUIT
End DoDot:2
+26 SET BN=0
SET QFL=0
FOR
SET BN=$ORDER(@TDATA@(BN))
IF 'BN!(QFL)
QUIT
IF @TDATA@(BN)["SUBJECT:"
SET NBN=BN
SET QFL=1
+27 SET BN=NBN
SET QFL=0
FOR
SET BN=$ORDER(@TDATA@(BN))
IF 'BN!(QFL)
QUIT
IF @TDATA@(BN)["----------"
SET LBN=BN
SET QFL=1
+28 SET FBN=LBN-1
+29 FOR BJ=NBN+1:1:$SELECT(FBN<66:FBN,1:62)
USE IO
WRITE !,@TDATA@(BJ)
+30 IF FBN>65
Begin DoDot:2
+31 WRITE @IOF
+32 FOR BJ=63:1:FBN
USE IO
WRITE !,@TDATA@(BJ)
End DoDot:2
+33 WRITE @IOF
End DoDot:1
+34 KILL @TDATA
+35 QUIT
