- BJPNPRNT ;GDIT/HS/BEE-Prenatal Care Module Print Handling Calls ; 08 May 2012 12:00 PM
- ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
- ;
- Q
- ;
- GDFLT(DATA,LOC) ;BJPN GET DEF PRNT
- ;
- ;Returns current default printer for user
- ;
- S LOC=+$G(LOC)
- ;
- NEW UID,II,RET
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("BJPNPRNT",UID))
- K @DATA
- I $G(DT)=""!($G(U)="") D DT^DICRW
- ;
- S II=0
- NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
- ;
- S II=II+1,@DATA@(II)="T00050IEN_NAME"_$C(30)
- ;
- ;Call CIAV API
- D PRTGETDF^CIAVUTIO(.RET,LOC)
- ;
- S II=II+1,@DATA@(II)=$G(RET)_$C(30)
- ;
- XGDF S II=II+1,@DATA@(II)=$C(31)
- Q
- ;
- SDFLT(DATA,DEV) ;BJPN SET DEF PRNT
- ;
- ;Sets the current default printer for user
- ;
- S DEV=$G(DEV)
- ;
- NEW UID,II,RET
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("BJPNPRNT",UID))
- K @DATA
- I $G(DT)=""!($G(U)="") D DT^DICRW
- ;
- S II=0
- NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
- ;
- S II=II+1,@DATA@(II)="T00050RESULT"_$C(30)
- ;
- ;Call CIAV API
- S RET=1 I $G(DEV)]"" D PRTSETDF^CIAVUTIO(.RET,DEV)
- ;
- S II=II+1,@DATA@(II)=+$G(RET)_$C(30)
- ;
- XSDF S II=II+1,@DATA@(II)=$C(31)
- Q
- ;
- DEVICE(DATA,FAKE) ;BJPN GET PRINTER LIST
- ;
- ;Returns the device list
- ;
- NEW UID,II,RET,TMP
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("BJPNPRNT",UID))
- S TMP=$NA(^TMP("BJPNPRT",UID))
- K @DATA,@TMP
- I $G(DT)=""!($G(U)="") D DT^DICRW
- ;
- S II=0
- NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
- ;
- S II=II+1,@DATA@(II)="T00050IEN_NAME^T00100DISPLAY_NAME^T00050LOCATION^I00099RIGHT_MARGIN^I00099PAGE_LENGTH"_$C(30)
- ;
- ;Call CIAV API - Retrieve up to 2000 printers
- D DEVICE^CIAVUTIO(.RET,"",1,2000)
- ;
- ;Copy to return global
- S RET="" F S RET=$O(RET(RET)) Q:RET="" S II=II+1,@DATA@(II)=RET(RET)_$C(30)
- ;
- XDEV K @TMP
- S II=II+1,@DATA@(II)=$C(31)
- Q
- ;
- DETPRT(DATA,PIPIEN,DEVICE,CP,RM,PL) ;BJPN PRINT DETAIL
- ;
- ;Prints the specific problem detail to the selected device
- ;
- ;Input:
- ; PIPIEN - Pointer to PIP problem
- ; DEVICE - Device to print on (IEN_NAME value)
- ; CP - Number of Copies
- ; RM - Right Margin
- ; PL - Page Length
- ;
- NEW UID,II,RET,HDR,FTR,SPACE,PNAME,AGE,DOB,PAD,DFN,H2,%,NOW,PNOW,CTMAX
- NEW COPY,DIEN,HRN,REPT
- ;
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("BJPNPRNT",UID))
- S REPT=$NA(^TMP("BJPNPBDT",UID))
- K @DATA,@REPT
- I $G(DT)=""!($G(U)="") D DT^DICRW
- ;
- S II=0
- NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
- ;
- ;Define Header
- S II=II+1,@DATA@(II)="T00001RESULT^T00080ERROR_MESSAGE"_$C(30)
- ;
- D NOW^%DTC S NOW=%,PNOW=$P($$FMTE^BJPNPRL(NOW),":",1,2)
- ;
- ;Data Validation
- I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^INVALID PIPIEN"_$C(30) G XPRT
- I $G(DEVICE)="" S II=II+1,@DATA@(II)="-1^INVALID DEVICE"_$C(30) G XPRT
- S DIEN=$P(DEVICE,";")
- S CP=$G(CP) S:'CP CP=1
- S:$G(RM)="" RM=$$GET1^DIQ(3.5,DIEN_",",9,"E") S:RM="" RM=80
- S:$G(PL)="" PL=$$GET1^DIQ(3.5,DIEN_",",11,"E") S:PL="" PL=65
- S CTMAX=PL-3
- ;
- ;Retrieve Patient Info
- S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",".02","I")
- S PNAME=$$GET1^DIQ(2,DFN_",",".01","E")
- S DOB=$$FMTE^BJPNPRL($$GET1^DIQ(2,DFN_",",.03,"I"))
- S AGE=$$AGE^AUPNPAT(DFN,,1),H2=DOB_" ("_AGE_")"
- S HRN=$$HRN^AUPNPAT(DFN,DUZ(2),"")
- ;
- ;Retrieve Detail
- D DET^BJPNPBDT("",PIPIEN)
- ;
- ;Define Report Header
- S SPACE=" ",$P(SPACE," ",RM)=" ",LINE="_",$P(LINE,"_",RM)="_"
- S PAD=(RM-$L("Prenatal Problem Detail"))\2
- S HDR(1)=$E(SPACE,1,PAD)_"Prenatal Problem Detail"
- S HDR(2)=PNAME_" "_HRN,PAD=RM-$L(HDR(2))-$L(H2),HDR(2)=HDR(2)_$E(SPACE,1,PAD)_H2
- S HDR(3)=LINE
- S HDR(4)="*** WORK COPY ONLY ***",PAD=RM-$L(HDR(4))-$L(PNOW)-9,HDR(4)=HDR(4)_$E(SPACE,1,PAD)_"Printed: "_PNOW
- ;
- ;Define Report Footer
- S FTR(1)=LINE
- S FTR(2)="Page "
- S FTR(3)=HDR(4)
- ;
- ;Print each copy
- F COPY=1:1:CP D PRINT(.HDR,.FTR,RM,CTMAX)
- ;
- ;Record success
- S II=II+1,@DATA@(II)="1^"_$C(30)
- ;
- Q
- ;
- XPRT S II=II+1,@DATA@(II)=$C(31)
- Q
- ;
- PRINT(HDR,FTR,RM,CTMAX) ;EP - Print each copy
- ;
- NEW CTL,PAGE,RLINE,OUT,PGBK,TTL,INDT
- ;
- ;Select (and skip) first line - Quit if no line
- S RLINE=$O(@REPT@("")) I RLINE="" Q
- S PAGE=1
- ;
- F D I $O(@REPT@(RLINE))="" Q
- . ;
- . ;Assemble Header
- . NEW REP,CT
- . S REP(1)=HDR(1)
- . S REP(2)=HDR(2)
- . S REP(3)=HDR(3)
- . S REP(4)=HDR(4)
- . ;
- . ;Add Report Data Lines
- . S CT=4 F D Q:(CT=CTMAX) Q:($O(@REPT@(RLINE))="")
- .. ;
- .. NEW VALUE,WRAP,CNTL
- .. ;
- .. ;Pull Next Line
- .. S RLINE=$O(@REPT@(RLINE)),VALUE=@REPT@(RLINE)
- .. F CNTL=13,10,30,31 S VALUE=$TR(VALUE,$C(CNTL))
- .. ;
- .. ;Wrap the Line
- .. D WRAP(.WRAP,VALUE,RM)
- .. ;
- .. ;Process each wrapped line
- .. S WRAP="" F S WRAP=$O(WRAP(WRAP)) Q:WRAP="" D
- ... S CT=CT+1,REP(CT)=WRAP(WRAP)
- . ;
- . ;Assemble Footer
- . S REP(CT+1)=FTR(1)
- . S REP(CT+2)=FTR(2)_PAGE
- . S REP(CT+3)=FTR(3)
- . ;I $O(@REPT@(RLINE))]"" S REP(CT+4)="**PAGE BREAK**"
- . ;
- . ;Define CTL
- . I PAGE=1 S CTL=0
- . ;
- . ;Final Parameters
- . S (TTL,DEV,PGBK,INDT)=""
- . I $O(@REPT@(RLINE))="" D
- .. S DEV=DEVICE
- .. S TTL="Prenatal Problem Detail"
- .. S PGBK=""
- .. S INDT=0
- . ;
- . ;Output Report
- . D PRINT^CIAVUTIO(.OUT,CTL,.REP,DEV,PGBK,INDT)
- . S CTL=+$G(OUT)
- . ;
- . ;Update Page
- . S PAGE=PAGE+1
- ;
- Q
- ;
- WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
- ;
- NEW SP
- ;
- I $G(TEXT)="" S OUT(1)="" Q
- I $G(RM)="" Q
- I $G(IND)="" S IND=0
- S $P(SP," ",80)=" "
- ;
- ;Strip out $c(10)
- S TEXT=$TR(TEXT,$C(10))
- ;
- F I $L(TEXT)>0 D Q:$L(TEXT)=0
- . NEW PIECE,SPACE,LINE
- . S PIECE=$E(TEXT,1,RM)
- . ;
- . ;Handle Line feeds
- . I PIECE[$C(13) D Q
- .. NEW LINE,I
- .. S LINE=$P(PIECE,$C(13)) S:LINE="" LINE=" "
- .. S OUT=$G(OUT)+1,OUT(OUT)=LINE
- .. F I=1:1:$L(PIECE) I $E(PIECE,I)=$C(13) Q
- .. S TEXT=$E(SP,1,IND)_$$STZ($E(TEXT,I+1,9999999999))
- . ;
- . ;Check if line is less than right margin
- . I $L(PIECE)<RM S OUT=$G(OUT)+1,OUT(OUT)=PIECE,TEXT="" Q
- . ;
- . ;Locate last space in line and handle if no space
- . F SPACE=$L(PIECE):-1:(IND+1) I $E(PIECE,SPACE)=" " Q
- . I (SPACE=(IND+1)) D S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT Q
- .. S LINE=PIECE,OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,RM+1,999999999))
- . ;
- . ;Handle line with space
- . S LINE=$E(PIECE,1,SPACE-1),OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,SPACE+1,999999999))
- . S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT
- ;
- Q
- ;
- STZ(TEXT) ;EP - Strip Leading Spaces
- NEW START
- F START=1:1:$L(TEXT) I $E(TEXT,START)'=" " Q
- Q $E(TEXT,START,9999999999)
- ;
- ERR ;
- D ^%ZTER
- NEW Y,ERRDTM
- S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
- S II=$G(II)+1,@DATA@(II)="-1"_$C(31)
- Q
- BJPNPRNT ;GDIT/HS/BEE-Prenatal Care Module Print Handling Calls ; 08 May 2012 12:00 PM
- +1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
- +2 ;
- +3 QUIT
- +4 ;
- GDFLT(DATA,LOC) ;BJPN GET DEF PRNT
- +1 ;
- +2 ;Returns current default printer for user
- +3 ;
- +4 SET LOC=+$GET(LOC)
- +5 ;
- +6 NEW UID,II,RET
- +7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +8 SET DATA=$NAME(^TMP("BJPNPRNT",UID))
- +9 KILL @DATA
- +10 IF $GET(DT)=""!($GET(U)="")
- DO DT^DICRW
- +11 ;
- +12 SET II=0
- +13 ; SAC 2009 2.2.3.17
- NEW $ESTACK,$ETRAP
- SET $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER"
- +14 ;
- +15 SET II=II+1
- SET @DATA@(II)="T00050IEN_NAME"_$CHAR(30)
- +16 ;
- +17 ;Call CIAV API
- +18 DO PRTGETDF^CIAVUTIO(.RET,LOC)
- +19 ;
- +20 SET II=II+1
- SET @DATA@(II)=$GET(RET)_$CHAR(30)
- +21 ;
- XGDF SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +1 QUIT
- +2 ;
- SDFLT(DATA,DEV) ;BJPN SET DEF PRNT
- +1 ;
- +2 ;Sets the current default printer for user
- +3 ;
- +4 SET DEV=$GET(DEV)
- +5 ;
- +6 NEW UID,II,RET
- +7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +8 SET DATA=$NAME(^TMP("BJPNPRNT",UID))
- +9 KILL @DATA
- +10 IF $GET(DT)=""!($GET(U)="")
- DO DT^DICRW
- +11 ;
- +12 SET II=0
- +13 ; SAC 2009 2.2.3.17
- NEW $ESTACK,$ETRAP
- SET $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER"
- +14 ;
- +15 SET II=II+1
- SET @DATA@(II)="T00050RESULT"_$CHAR(30)
- +16 ;
- +17 ;Call CIAV API
- +18 SET RET=1
- IF $GET(DEV)]""
- DO PRTSETDF^CIAVUTIO(.RET,DEV)
- +19 ;
- +20 SET II=II+1
- SET @DATA@(II)=+$GET(RET)_$CHAR(30)
- +21 ;
- XSDF SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +1 QUIT
- +2 ;
- DEVICE(DATA,FAKE) ;BJPN GET PRINTER LIST
- +1 ;
- +2 ;Returns the device list
- +3 ;
- +4 NEW UID,II,RET,TMP
- +5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +6 SET DATA=$NAME(^TMP("BJPNPRNT",UID))
- +7 SET TMP=$NAME(^TMP("BJPNPRT",UID))
- +8 KILL @DATA,@TMP
- +9 IF $GET(DT)=""!($GET(U)="")
- DO DT^DICRW
- +10 ;
- +11 SET II=0
- +12 ; SAC 2009 2.2.3.17
- NEW $ESTACK,$ETRAP
- SET $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER"
- +13 ;
- +14 SET II=II+1
- SET @DATA@(II)="T00050IEN_NAME^T00100DISPLAY_NAME^T00050LOCATION^I00099RIGHT_MARGIN^I00099PAGE_LENGTH"_$CHAR(30)
- +15 ;
- +16 ;Call CIAV API - Retrieve up to 2000 printers
- +17 DO DEVICE^CIAVUTIO(.RET,"",1,2000)
- +18 ;
- +19 ;Copy to return global
- +20 SET RET=""
- FOR
- SET RET=$ORDER(RET(RET))
- IF RET=""
- QUIT
- SET II=II+1
- SET @DATA@(II)=RET(RET)_$CHAR(30)
- +21 ;
- XDEV KILL @TMP
- +1 SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +2 QUIT
- +3 ;
- DETPRT(DATA,PIPIEN,DEVICE,CP,RM,PL) ;BJPN PRINT DETAIL
- +1 ;
- +2 ;Prints the specific problem detail to the selected device
- +3 ;
- +4 ;Input:
- +5 ; PIPIEN - Pointer to PIP problem
- +6 ; DEVICE - Device to print on (IEN_NAME value)
- +7 ; CP - Number of Copies
- +8 ; RM - Right Margin
- +9 ; PL - Page Length
- +10 ;
- +11 NEW UID,II,RET,HDR,FTR,SPACE,PNAME,AGE,DOB,PAD,DFN,H2,%,NOW,PNOW,CTMAX
- +12 NEW COPY,DIEN,HRN,REPT
- +13 ;
- +14 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +15 SET DATA=$NAME(^TMP("BJPNPRNT",UID))
- +16 SET REPT=$NAME(^TMP("BJPNPBDT",UID))
- +17 KILL @DATA,@REPT
- +18 IF $GET(DT)=""!($GET(U)="")
- DO DT^DICRW
- +19 ;
- +20 SET II=0
- +21 ; SAC 2009 2.2.3.17
- NEW $ESTACK,$ETRAP
- SET $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER"
- +22 ;
- +23 ;Define Header
- +24 SET II=II+1
- SET @DATA@(II)="T00001RESULT^T00080ERROR_MESSAGE"_$CHAR(30)
- +25 ;
- +26 DO NOW^%DTC
- SET NOW=%
- SET PNOW=$PIECE($$FMTE^BJPNPRL(NOW),":",1,2)
- +27 ;
- +28 ;Data Validation
- +29 IF $GET(PIPIEN)=""
- SET II=II+1
- SET @DATA@(II)="-1^INVALID PIPIEN"_$CHAR(30)
- GOTO XPRT
- +30 IF $GET(DEVICE)=""
- SET II=II+1
- SET @DATA@(II)="-1^INVALID DEVICE"_$CHAR(30)
- GOTO XPRT
- +31 SET DIEN=$PIECE(DEVICE,";")
- +32 SET CP=$GET(CP)
- IF 'CP
- SET CP=1
- +33 IF $GET(RM)=""
- SET RM=$$GET1^DIQ(3.5,DIEN_",",9,"E")
- IF RM=""
- SET RM=80
- +34 IF $GET(PL)=""
- SET PL=$$GET1^DIQ(3.5,DIEN_",",11,"E")
- IF PL=""
- SET PL=65
- +35 SET CTMAX=PL-3
- +36 ;
- +37 ;Retrieve Patient Info
- +38 SET DFN=$$GET1^DIQ(90680.01,PIPIEN_",",".02","I")
- +39 SET PNAME=$$GET1^DIQ(2,DFN_",",".01","E")
- +40 SET DOB=$$FMTE^BJPNPRL($$GET1^DIQ(2,DFN_",",.03,"I"))
- +41 SET AGE=$$AGE^AUPNPAT(DFN,,1)
- SET H2=DOB_" ("_AGE_")"
- +42 SET HRN=$$HRN^AUPNPAT(DFN,DUZ(2),"")
- +43 ;
- +44 ;Retrieve Detail
- +45 DO DET^BJPNPBDT("",PIPIEN)
- +46 ;
- +47 ;Define Report Header
- +48 SET SPACE=" "
- SET $PIECE(SPACE," ",RM)=" "
- SET LINE="_"
- SET $PIECE(LINE,"_",RM)="_"
- +49 SET PAD=(RM-$LENGTH("Prenatal Problem Detail"))\2
- +50 SET HDR(1)=$EXTRACT(SPACE,1,PAD)_"Prenatal Problem Detail"
- +51 SET HDR(2)=PNAME_" "_HRN
- SET PAD=RM-$LENGTH(HDR(2))-$LENGTH(H2)
- SET HDR(2)=HDR(2)_$EXTRACT(SPACE,1,PAD)_H2
- +52 SET HDR(3)=LINE
- +53 SET HDR(4)="*** WORK COPY ONLY ***"
- SET PAD=RM-$LENGTH(HDR(4))-$LENGTH(PNOW)-9
- SET HDR(4)=HDR(4)_$EXTRACT(SPACE,1,PAD)_"Printed: "_PNOW
- +54 ;
- +55 ;Define Report Footer
- +56 SET FTR(1)=LINE
- +57 SET FTR(2)="Page "
- +58 SET FTR(3)=HDR(4)
- +59 ;
- +60 ;Print each copy
- +61 FOR COPY=1:1:CP
- DO PRINT(.HDR,.FTR,RM,CTMAX)
- +62 ;
- +63 ;Record success
- +64 SET II=II+1
- SET @DATA@(II)="1^"_$CHAR(30)
- +65 ;
- +66 QUIT
- +67 ;
- XPRT SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +1 QUIT
- +2 ;
- PRINT(HDR,FTR,RM,CTMAX) ;EP - Print each copy
- +1 ;
- +2 NEW CTL,PAGE,RLINE,OUT,PGBK,TTL,INDT
- +3 ;
- +4 ;Select (and skip) first line - Quit if no line
- +5 SET RLINE=$ORDER(@REPT@(""))
- IF RLINE=""
- QUIT
- +6 SET PAGE=1
- +7 ;
- +8 FOR
- Begin DoDot:1
- +9 ;
- +10 ;Assemble Header
- +11 NEW REP,CT
- +12 SET REP(1)=HDR(1)
- +13 SET REP(2)=HDR(2)
- +14 SET REP(3)=HDR(3)
- +15 SET REP(4)=HDR(4)
- +16 ;
- +17 ;Add Report Data Lines
- +18 SET CT=4
- FOR
- Begin DoDot:2
- +19 ;
- +20 NEW VALUE,WRAP,CNTL
- +21 ;
- +22 ;Pull Next Line
- +23 SET RLINE=$ORDER(@REPT@(RLINE))
- SET VALUE=@REPT@(RLINE)
- +24 FOR CNTL=13,10,30,31
- SET VALUE=$TRANSLATE(VALUE,$CHAR(CNTL))
- +25 ;
- +26 ;Wrap the Line
- +27 DO WRAP(.WRAP,VALUE,RM)
- +28 ;
- +29 ;Process each wrapped line
- +30 SET WRAP=""
- FOR
- SET WRAP=$ORDER(WRAP(WRAP))
- IF WRAP=""
- QUIT
- Begin DoDot:3
- +31 SET CT=CT+1
- SET REP(CT)=WRAP(WRAP)
- End DoDot:3
- End DoDot:2
- IF (CT=CTMAX)
- QUIT
- IF ($ORDER(@REPT@(RLINE))="")
- QUIT
- +32 ;
- +33 ;Assemble Footer
- +34 SET REP(CT+1)=FTR(1)
- +35 SET REP(CT+2)=FTR(2)_PAGE
- +36 SET REP(CT+3)=FTR(3)
- +37 ;I $O(@REPT@(RLINE))]"" S REP(CT+4)="**PAGE BREAK**"
- +38 ;
- +39 ;Define CTL
- +40 IF PAGE=1
- SET CTL=0
- +41 ;
- +42 ;Final Parameters
- +43 SET (TTL,DEV,PGBK,INDT)=""
- +44 IF $ORDER(@REPT@(RLINE))=""
- Begin DoDot:2
- +45 SET DEV=DEVICE
- +46 SET TTL="Prenatal Problem Detail"
- +47 SET PGBK=""
- +48 SET INDT=0
- End DoDot:2
- +49 ;
- +50 ;Output Report
- +51 DO PRINT^CIAVUTIO(.OUT,CTL,.REP,DEV,PGBK,INDT)
- +52 SET CTL=+$GET(OUT)
- +53 ;
- +54 ;Update Page
- +55 SET PAGE=PAGE+1
- End DoDot:1
- IF $ORDER(@REPT@(RLINE))=""
- QUIT
- +56 ;
- +57 QUIT
- +58 ;
- WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
- +1 ;
- +2 NEW SP
- +3 ;
- +4 IF $GET(TEXT)=""
- SET OUT(1)=""
- QUIT
- +5 IF $GET(RM)=""
- QUIT
- +6 IF $GET(IND)=""
- SET IND=0
- +7 SET $PIECE(SP," ",80)=" "
- +8 ;
- +9 ;Strip out $c(10)
- +10 SET TEXT=$TRANSLATE(TEXT,$CHAR(10))
- +11 ;
- +12 FOR
- IF $LENGTH(TEXT)>0
- Begin DoDot:1
- +13 NEW PIECE,SPACE,LINE
- +14 SET PIECE=$EXTRACT(TEXT,1,RM)
- +15 ;
- +16 ;Handle Line feeds
- +17 IF PIECE[$CHAR(13)
- Begin DoDot:2
- +18 NEW LINE,I
- +19 SET LINE=$PIECE(PIECE,$CHAR(13))
- IF LINE=""
- SET LINE=" "
- +20 SET OUT=$GET(OUT)+1
- SET OUT(OUT)=LINE
- +21 FOR I=1:1:$LENGTH(PIECE)
- IF $EXTRACT(PIECE,I)=$CHAR(13)
- QUIT
- +22 SET TEXT=$EXTRACT(SP,1,IND)_$$STZ($EXTRACT(TEXT,I+1,9999999999))
- End DoDot:2
- QUIT
- +23 ;
- +24 ;Check if line is less than right margin
- +25 IF $LENGTH(PIECE)<RM
- SET OUT=$GET(OUT)+1
- SET OUT(OUT)=PIECE
- SET TEXT=""
- QUIT
- +26 ;
- +27 ;Locate last space in line and handle if no space
- +28 FOR SPACE=$LENGTH(PIECE):-1:(IND+1)
- IF $EXTRACT(PIECE,SPACE)=" "
- QUIT
- +29 IF (SPACE=(IND+1))
- Begin DoDot:2
- +30 SET LINE=PIECE
- SET OUT=$GET(OUT)+1
- SET OUT(OUT)=LINE
- SET TEXT=$$STZ($EXTRACT(TEXT,RM+1,999999999))
- End DoDot:2
- IF TEXT]""
- SET TEXT=$EXTRACT(SP,1,IND)_TEXT
- QUIT
- +31 ;
- +32 ;Handle line with space
- +33 SET LINE=$EXTRACT(PIECE,1,SPACE-1)
- SET OUT=$GET(OUT)+1
- SET OUT(OUT)=LINE
- SET TEXT=$$STZ($EXTRACT(TEXT,SPACE+1,999999999))
- +34 IF TEXT]""
- SET TEXT=$EXTRACT(SP,1,IND)_TEXT
- End DoDot:1
- IF $LENGTH(TEXT)=0
- QUIT
- +35 ;
- +36 QUIT
- +37 ;
- STZ(TEXT) ;EP - Strip Leading Spaces
- +1 NEW START
- +2 FOR START=1:1:$LENGTH(TEXT)
- IF $EXTRACT(TEXT,START)'=" "
- QUIT
- +3 QUIT $EXTRACT(TEXT,START,9999999999)
- +4 ;
- ERR ;
- +1 DO ^%ZTER
- +2 NEW Y,ERRDTM
- +3 SET Y=$$NOW^XLFDT()
- XECUTE ^DD("DD")
- SET ERRDTM=Y
- +4 SET II=$GET(II)+1
- SET @DATA@(II)="-1"_$CHAR(31)
- +5 QUIT