Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BJPNPRNT

BJPNPRNT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. GDFLT(DATA,LOC) ;BJPN GET DEF PRNT
  1. ;
  1. ;Returns current default printer for user
  1. ;
  1. S LOC=+$G(LOC)
  1. ;
  1. NEW UID,II,RET
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BJPNPRNT",UID))
  1. K @DATA
  1. I $G(DT)=""!($G(U)="") D DT^DICRW
  1. ;
  1. S II=0
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1. ;
  1. S II=II+1,@DATA@(II)="T00050IEN_NAME"_$C(30)
  1. ;
  1. ;Call CIAV API
  1. D PRTGETDF^CIAVUTIO(.RET,LOC)
  1. ;
  1. S II=II+1,@DATA@(II)=$G(RET)_$C(30)
  1. ;
  1. XGDF S II=II+1,@DATA@(II)=$C(31)
  1. Q
  1. ;
  1. SDFLT(DATA,DEV) ;BJPN SET DEF PRNT
  1. ;
  1. ;Sets the current default printer for user
  1. ;
  1. S DEV=$G(DEV)
  1. ;
  1. NEW UID,II,RET
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BJPNPRNT",UID))
  1. K @DATA
  1. I $G(DT)=""!($G(U)="") D DT^DICRW
  1. ;
  1. S II=0
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1. ;
  1. S II=II+1,@DATA@(II)="T00050RESULT"_$C(30)
  1. ;
  1. ;Call CIAV API
  1. S RET=1 I $G(DEV)]"" D PRTSETDF^CIAVUTIO(.RET,DEV)
  1. ;
  1. S II=II+1,@DATA@(II)=+$G(RET)_$C(30)
  1. ;
  1. XSDF S II=II+1,@DATA@(II)=$C(31)
  1. Q
  1. ;
  1. DEVICE(DATA,FAKE) ;BJPN GET PRINTER LIST
  1. ;
  1. ;Returns the device list
  1. ;
  1. NEW UID,II,RET,TMP
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BJPNPRNT",UID))
  1. S TMP=$NA(^TMP("BJPNPRT",UID))
  1. K @DATA,@TMP
  1. I $G(DT)=""!($G(U)="") D DT^DICRW
  1. ;
  1. S II=0
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1. ;
  1. S II=II+1,@DATA@(II)="T00050IEN_NAME^T00100DISPLAY_NAME^T00050LOCATION^I00099RIGHT_MARGIN^I00099PAGE_LENGTH"_$C(30)
  1. ;
  1. ;Call CIAV API - Retrieve up to 2000 printers
  1. D DEVICE^CIAVUTIO(.RET,"",1,2000)
  1. ;
  1. ;Copy to return global
  1. S RET="" F S RET=$O(RET(RET)) Q:RET="" S II=II+1,@DATA@(II)=RET(RET)_$C(30)
  1. ;
  1. XDEV K @TMP
  1. S II=II+1,@DATA@(II)=$C(31)
  1. Q
  1. ;
  1. DETPRT(DATA,PIPIEN,DEVICE,CP,RM,PL) ;BJPN PRINT DETAIL
  1. ;
  1. ;Prints the specific problem detail to the selected device
  1. ;
  1. ;Input:
  1. ; PIPIEN - Pointer to PIP problem
  1. ; DEVICE - Device to print on (IEN_NAME value)
  1. ; CP - Number of Copies
  1. ; RM - Right Margin
  1. ; PL - Page Length
  1. ;
  1. NEW UID,II,RET,HDR,FTR,SPACE,PNAME,AGE,DOB,PAD,DFN,H2,%,NOW,PNOW,CTMAX
  1. NEW COPY,DIEN,HRN,REPT
  1. ;
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BJPNPRNT",UID))
  1. S REPT=$NA(^TMP("BJPNPBDT",UID))
  1. K @DATA,@REPT
  1. I $G(DT)=""!($G(U)="") D DT^DICRW
  1. ;
  1. S II=0
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRNT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1. ;
  1. ;Define Header
  1. S II=II+1,@DATA@(II)="T00001RESULT^T00080ERROR_MESSAGE"_$C(30)
  1. ;
  1. D NOW^%DTC S NOW=%,PNOW=$P($$FMTE^BJPNPRL(NOW),":",1,2)
  1. ;
  1. ;Data Validation
  1. I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^INVALID PIPIEN"_$C(30) G XPRT
  1. I $G(DEVICE)="" S II=II+1,@DATA@(II)="-1^INVALID DEVICE"_$C(30) G XPRT
  1. S DIEN=$P(DEVICE,";")
  1. S CP=$G(CP) S:'CP CP=1
  1. S:$G(RM)="" RM=$$GET1^DIQ(3.5,DIEN_",",9,"E") S:RM="" RM=80
  1. S:$G(PL)="" PL=$$GET1^DIQ(3.5,DIEN_",",11,"E") S:PL="" PL=65
  1. S CTMAX=PL-3
  1. ;
  1. ;Retrieve Patient Info
  1. S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",".02","I")
  1. S PNAME=$$GET1^DIQ(2,DFN_",",".01","E")
  1. S DOB=$$FMTE^BJPNPRL($$GET1^DIQ(2,DFN_",",.03,"I"))
  1. S AGE=$$AGE^AUPNPAT(DFN,,1),H2=DOB_" ("_AGE_")"
  1. S HRN=$$HRN^AUPNPAT(DFN,DUZ(2),"")
  1. ;
  1. ;Retrieve Detail
  1. D DET^BJPNPBDT("",PIPIEN)
  1. ;
  1. ;Define Report Header
  1. S SPACE=" ",$P(SPACE," ",RM)=" ",LINE="_",$P(LINE,"_",RM)="_"
  1. S PAD=(RM-$L("Prenatal Problem Detail"))\2
  1. S HDR(1)=$E(SPACE,1,PAD)_"Prenatal Problem Detail"
  1. S HDR(2)=PNAME_" "_HRN,PAD=RM-$L(HDR(2))-$L(H2),HDR(2)=HDR(2)_$E(SPACE,1,PAD)_H2
  1. S HDR(3)=LINE
  1. S HDR(4)="*** WORK COPY ONLY ***",PAD=RM-$L(HDR(4))-$L(PNOW)-9,HDR(4)=HDR(4)_$E(SPACE,1,PAD)_"Printed: "_PNOW
  1. ;
  1. ;Define Report Footer
  1. S FTR(1)=LINE
  1. S FTR(2)="Page "
  1. S FTR(3)=HDR(4)
  1. ;
  1. ;Print each copy
  1. F COPY=1:1:CP D PRINT(.HDR,.FTR,RM,CTMAX)
  1. ;
  1. ;Record success
  1. S II=II+1,@DATA@(II)="1^"_$C(30)
  1. ;
  1. Q
  1. ;
  1. XPRT S II=II+1,@DATA@(II)=$C(31)
  1. Q
  1. ;
  1. PRINT(HDR,FTR,RM,CTMAX) ;EP - Print each copy
  1. ;
  1. NEW CTL,PAGE,RLINE,OUT,PGBK,TTL,INDT
  1. ;
  1. ;Select (and skip) first line - Quit if no line
  1. S RLINE=$O(@REPT@("")) I RLINE="" Q
  1. S PAGE=1
  1. ;
  1. F D I $O(@REPT@(RLINE))="" Q
  1. . ;
  1. . ;Assemble Header
  1. . NEW REP,CT
  1. . S REP(1)=HDR(1)
  1. . S REP(2)=HDR(2)
  1. . S REP(3)=HDR(3)
  1. . S REP(4)=HDR(4)
  1. . ;
  1. . ;Add Report Data Lines
  1. . S CT=4 F D Q:(CT=CTMAX) Q:($O(@REPT@(RLINE))="")
  1. .. ;
  1. .. NEW VALUE,WRAP,CNTL
  1. .. ;
  1. .. ;Pull Next Line
  1. .. S RLINE=$O(@REPT@(RLINE)),VALUE=@REPT@(RLINE)
  1. .. F CNTL=13,10,30,31 S VALUE=$TR(VALUE,$C(CNTL))
  1. .. ;
  1. .. ;Wrap the Line
  1. .. D WRAP(.WRAP,VALUE,RM)
  1. .. ;
  1. .. ;Process each wrapped line
  1. .. S WRAP="" F S WRAP=$O(WRAP(WRAP)) Q:WRAP="" D
  1. ... S CT=CT+1,REP(CT)=WRAP(WRAP)
  1. . ;
  1. . ;Assemble Footer
  1. . S REP(CT+1)=FTR(1)
  1. . S REP(CT+2)=FTR(2)_PAGE
  1. . S REP(CT+3)=FTR(3)
  1. . ;I $O(@REPT@(RLINE))]"" S REP(CT+4)="**PAGE BREAK**"
  1. . ;
  1. . ;Define CTL
  1. . I PAGE=1 S CTL=0
  1. . ;
  1. . ;Final Parameters
  1. . S (TTL,DEV,PGBK,INDT)=""
  1. . I $O(@REPT@(RLINE))="" D
  1. .. S DEV=DEVICE
  1. .. S TTL="Prenatal Problem Detail"
  1. .. S PGBK=""
  1. .. S INDT=0
  1. . ;
  1. . ;Output Report
  1. . D PRINT^CIAVUTIO(.OUT,CTL,.REP,DEV,PGBK,INDT)
  1. . S CTL=+$G(OUT)
  1. . ;
  1. . ;Update Page
  1. . S PAGE=PAGE+1
  1. ;
  1. Q
  1. ;
  1. WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
  1. ;
  1. NEW SP
  1. ;
  1. I $G(TEXT)="" S OUT(1)="" Q
  1. I $G(RM)="" Q
  1. I $G(IND)="" S IND=0
  1. S $P(SP," ",80)=" "
  1. ;
  1. ;Strip out $c(10)
  1. S TEXT=$TR(TEXT,$C(10))
  1. ;
  1. F I $L(TEXT)>0 D Q:$L(TEXT)=0
  1. . NEW PIECE,SPACE,LINE
  1. . S PIECE=$E(TEXT,1,RM)
  1. . ;
  1. . ;Handle Line feeds
  1. . I PIECE[$C(13) D Q
  1. .. NEW LINE,I
  1. .. S LINE=$P(PIECE,$C(13)) S:LINE="" LINE=" "
  1. .. S OUT=$G(OUT)+1,OUT(OUT)=LINE
  1. .. F I=1:1:$L(PIECE) I $E(PIECE,I)=$C(13) Q
  1. .. S TEXT=$E(SP,1,IND)_$$STZ($E(TEXT,I+1,9999999999))
  1. . ;
  1. . ;Check if line is less than right margin
  1. . I $L(PIECE)<RM S OUT=$G(OUT)+1,OUT(OUT)=PIECE,TEXT="" Q
  1. . ;
  1. . ;Locate last space in line and handle if no space
  1. . F SPACE=$L(PIECE):-1:(IND+1) I $E(PIECE,SPACE)=" " Q
  1. . I (SPACE=(IND+1)) D S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT Q
  1. .. S LINE=PIECE,OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,RM+1,999999999))
  1. . ;
  1. . ;Handle line with space
  1. . S LINE=$E(PIECE,1,SPACE-1),OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,SPACE+1,999999999))
  1. . S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT
  1. ;
  1. Q
  1. ;
  1. STZ(TEXT) ;EP - Strip Leading Spaces
  1. NEW START
  1. F START=1:1:$L(TEXT) I $E(TEXT,START)'=" " Q
  1. Q $E(TEXT,START,9999999999)
  1. ;
  1. ERR ;
  1. D ^%ZTER
  1. NEW Y,ERRDTM
  1. S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1. S II=$G(II)+1,@DATA@(II)="-1"_$C(31)
  1. Q