APCLPRT ; IHS/CMI/LAB - PRINTS REPORTS USING REPORT TEMPLATE FILE ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;CMI/TUCSON/LAB - patch 3 - 10/26/1998 - Y2K fixes
EN(APCLDFN,APCLROOT,APCLPD) ;PEP - create report
I '$D(APCLROOT) W !,*7,"Global root not indicated!" Q
I '$D(ZTQUEUED),$P(IOST,"-")="C" S APCLBRK="" W @IOF
S APCLENDR=$E(APCLROOT,$L(APCLROOT)) I "(,"[APCLENDR S APCLROOT=$E(APCLROOT,1,($L(APCLROOT)-1))
S APCLENDR=$E(APCLROOT,$L(APCLROOT)) I APCLENDR'=")",APCLROOT["(" S APCLROOT=APCLROOT_")"
S (APCLOOP,APCLCNT,APCLSTP)=0 F S APCLOOP=$O(^APCLRPT(APCLDFN,21,APCLOOP)) Q:'APCLOOP!APCLSTP S APCLL=0 S APCLLINE=^(APCLOOP,0) D D APCLWRTE
. F I=1:1 Q:$P(APCLLINE,"|",2,99)="" S APCLN=+$P(APCLLINE,"|",2),APCLTMP=$P(APCLLINE,"|") S APCLV=$S($D(@APCLROOT@(APCLN)):@APCLROOT@(APCLN),1:"") D:APCLV="" CODE D:APCLV]""&($P($G(^APCLRPT(APCLDFN,31,APCLN,0)),U,2)="p") PCT D K APCLCODE
.. I ($L(APCLTMP)+$L(APCLV))>$S($D(APCLCODE):250,1:IOM) S APCLL=APCLL+1 S APCLWRTE(APCLL)=APCLTMP S APCLLINE=APCLV_$P(APCLLINE,"|",3,999) Q
.. S APCLTMP=APCLTMP_APCLV
.. I ($L(APCLTMP)+$L($P(APCLLINE,"|",3,999)))>IOM S APCLL=APCLL+1 S APCLWRTE(APCLL)=APCLTMP S APCLLINE=$P(APCLLINE,"|",3,999) Q
.. S APCLLINE=APCLTMP_$P(APCLLINE,"|",3,999)
. S APCLL=APCLL+1 S APCLWRTE(APCLL)=APCLLINE
I $D(APCLBRK),'APCLSTP D PAGE I 1
E W @IOF
K APCLOOP,APCLBRK,APCLCNT,APCLI,APCLTMP,APCLL,APCLLINE,APCLN,APCLV,APCLWRTE,APCLX,APCLENDR
I '$D(APCLASK) K APCLSTP
Q
;
CODE ; Get date or value from data fetcher
NEW APCLDIS,APCLI,APCLSTP
K APCLER
I $G(APCLPD),$G(^APCLRPT(APCLDFN,31,APCLN,21))]"" S APCLCODE=^(21) D
. I APCLCODE["*" S APCLV="Script error - '*' entered as a value!" Q
. I $G(APCLDATE)]"",$P(APCLCODE,";",2)]"" S APCLV="Script error - date information entered!" Q
. S APCLDIS=$S($P(APCLCODE," ")="DATE":"DATE",$P(APCLCODE," ")="VALUE"!("PATPT"[$P(APCLCODE," ")):"VALUE",1:"BOTH")
. I $E($P(APCLCODE," "),1,3)["PAT"!($E($P(APCLCODE," "),1,2)["PT")
. E I APCLDIS="DATE"!(APCLDIS="VALUE") S APCLCODE=$P(APCLCODE," ",2,99)
. I $E($P(APCLCODE," "),1,3)'="PAT",$E($P(APCLCODE," "),1,2)'="PT" S APCLCODE=APCLCODE_$G(APCLDATE)
. S APCLX=APCLPD_"^"_APCLCODE,APCLY="APCLDF(" S APCLER=$$START1^APCLDF(APCLX,APCLY) K APCLX,APCLY
. I APCLER S APCLV="Data Retrieval Error!" K APCLER Q
. K APCLER
. I '$D(APCLDF) S APCLV="None Found" K APCLDF Q
. I APCLDIS="BOTH"!(APCLDIS="DATE") F APCLI=1:1 Q:'$D(APCLDF(APCLI)) D Q:$G(APCLSTP) D SET
.. I ($L(APCLV)+6)>246 S APCLSTP=1,APCLV=APCLV_" ...etc."
. I APCLDIS'="VALUE" K APCLDF Q
. F APCLI=1:1 Q:'$D(APCLDF(APCLI)) D Q:$G(APCLSTP) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$P(APCLDF(APCLI),U,2)
.. I ($L(APCLV)+6)>246 S APCLSTP=1,APCLV=APCLV_" ...etc."
. K APCLDF,APCLPCE
Q
;
SET ; Set Value and or Date from PCC SCRIPT
;beginning Y2K fix. Modified line to use a 4 digit year rather than a 2 digit year. Not sure is this was necessary but it will work either way.
;S Y=$P(APCLDF(APCLI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$S(APCLDIS="BOTH":$P(APCLDF(APCLI),U,2)_" - "_Y,1:Y)
S Y=$P(APCLDF(APCLI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3)) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$S(APCLDIS="BOTH":$P(APCLDF(APCLI),U,2)_" - "_Y,1:Y) ;Y2000
;end Y2K fix
Q
;
APCLWRTE ; Write line
I APCLWRTE(1)="@",$D(APCLBRK) D PAGE G X1
I APCLWRTE(1)="@" W @IOF S APCLCNT=0 G X1
F APCLX=1:1:APCLL Q:APCLSTP W !,APCLWRTE(APCLX) S APCLCNT=APCLCNT+1 I $D(APCLBRK),(IOSL-3)<APCLCNT D PAGE
X2 K APCLWRTE
Q
;
PAGE ; Page Control
W !
S DIR(0)="E" D ^DIR K DIR
I Y S APCLCNT=0
E S APCLSTP=1
W @IOF
Q
;
PCT ; Determine APCL
S @("APCLV="_APCLV)
S APCLV=APCLV*100,APCLV=$J(APCLV,3,0)_"%"
X1 Q
;
APCLPRT ; IHS/CMI/LAB - PRINTS REPORTS USING REPORT TEMPLATE FILE ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;CMI/TUCSON/LAB - patch 3 - 10/26/1998 - Y2K fixes
EN(APCLDFN,APCLROOT,APCLPD) ;PEP - create report
+1 IF '$DATA(APCLROOT)
WRITE !,*7,"Global root not indicated!"
QUIT
+2 IF '$DATA(ZTQUEUED)
IF $PIECE(IOST,"-")="C"
SET APCLBRK=""
WRITE @IOF
+3 SET APCLENDR=$EXTRACT(APCLROOT,$LENGTH(APCLROOT))
IF "(,"[APCLENDR
SET APCLROOT=$EXTRACT(APCLROOT,1,($LENGTH(APCLROOT)-1))
+4 SET APCLENDR=$EXTRACT(APCLROOT,$LENGTH(APCLROOT))
IF APCLENDR'=")"
IF APCLROOT["("
SET APCLROOT=APCLROOT_")"
+5 SET (APCLOOP,APCLCNT,APCLSTP)=0
FOR
SET APCLOOP=$ORDER(^APCLRPT(APCLDFN,21,APCLOOP))
IF 'APCLOOP!APCLSTP
QUIT
SET APCLL=0
SET APCLLINE=^(APCLOOP,0)
Begin DoDot:1
+6 FOR I=1:1
IF $PIECE(APCLLINE,"|",2,99)=""
QUIT
SET APCLN=+$PIECE(APCLLINE,"|",2)
SET APCLTMP=$PIECE(APCLLINE,"|")
SET APCLV=$SELECT($DATA(@APCLROOT@(APCLN)):@APCLROOT@(APCLN),1:"")
IF APCLV=""
DO CODE
IF APCLV]""&($PIECE($GET(^APCLRPT(APCLDFN,31,APCLN,0)),U,2)="p")
DO PCT
Begin DoDot:2
+7 IF ($LENGTH(APCLTMP)+$LENGTH(APCLV))>$SELECT($DATA(APCLCODE):250,1:IOM)
SET APCLL=APCLL+1
SET APCLWRTE(APCLL)=APCLTMP
SET APCLLINE=APCLV_$PIECE(APCLLINE,"|",3,999)
QUIT
+8 SET APCLTMP=APCLTMP_APCLV
+9 IF ($LENGTH(APCLTMP)+$LENGTH($PIECE(APCLLINE,"|",3,999)))>IOM
SET APCLL=APCLL+1
SET APCLWRTE(APCLL)=APCLTMP
SET APCLLINE=$PIECE(APCLLINE,"|",3,999)
QUIT
+10 SET APCLLINE=APCLTMP_$PIECE(APCLLINE,"|",3,999)
End DoDot:2
KILL APCLCODE
+11 SET APCLL=APCLL+1
SET APCLWRTE(APCLL)=APCLLINE
End DoDot:1
DO APCLWRTE
+12 IF $DATA(APCLBRK)
IF 'APCLSTP
DO PAGE
IF 1
+13 IF '$TEST
WRITE @IOF
+14 KILL APCLOOP,APCLBRK,APCLCNT,APCLI,APCLTMP,APCLL,APCLLINE,APCLN,APCLV,APCLWRTE,APCLX,APCLENDR
+15 IF '$DATA(APCLASK)
KILL APCLSTP
+16 QUIT
+17 ;
CODE ; Get date or value from data fetcher
+1 NEW APCLDIS,APCLI,APCLSTP
+2 KILL APCLER
+3 IF $GET(APCLPD)
IF $GET(^APCLRPT(APCLDFN,31,APCLN,21))]""
SET APCLCODE=^(21)
Begin DoDot:1
+4 IF APCLCODE["*"
SET APCLV="Script error - '*' entered as a value!"
QUIT
+5 IF $GET(APCLDATE)]""
IF $PIECE(APCLCODE,";",2)]""
SET APCLV="Script error - date information entered!"
QUIT
+6 SET APCLDIS=$SELECT($PIECE(APCLCODE," ")="DATE":"DATE",$PIECE(APCLCODE," ")="VALUE"!("PATPT"[$PIECE(APCLCODE," ")):"VALUE",1:"BOTH")
+7 IF $EXTRACT($PIECE(APCLCODE," "),1,3)["PAT"!($EXTRACT($PIECE(APCLCODE," "),1,2)["PT")
+8 IF '$TEST
IF APCLDIS="DATE"!(APCLDIS="VALUE")
SET APCLCODE=$PIECE(APCLCODE," ",2,99)
+9 IF $EXTRACT($PIECE(APCLCODE," "),1,3)'="PAT"
IF $EXTRACT($PIECE(APCLCODE," "),1,2)'="PT"
SET APCLCODE=APCLCODE_$GET(APCLDATE)
+10 SET APCLX=APCLPD_"^"_APCLCODE
SET APCLY="APCLDF("
SET APCLER=$$START1^APCLDF(APCLX,APCLY)
KILL APCLX,APCLY
+11 IF APCLER
SET APCLV="Data Retrieval Error!"
KILL APCLER
QUIT
+12 KILL APCLER
+13 IF '$DATA(APCLDF)
SET APCLV="None Found"
KILL APCLDF
QUIT
+14 IF APCLDIS="BOTH"!(APCLDIS="DATE")
FOR APCLI=1:1
IF '$DATA(APCLDF(APCLI))
QUIT
Begin DoDot:2
+15 IF ($LENGTH(APCLV)+6)>246
SET APCLSTP=1
SET APCLV=APCLV_" ...etc."
End DoDot:2
IF $GET(APCLSTP)
QUIT
DO SET
+16 IF APCLDIS'="VALUE"
KILL APCLDF
QUIT
+17 FOR APCLI=1:1
IF '$DATA(APCLDF(APCLI))
QUIT
Begin DoDot:2
+18 IF ($LENGTH(APCLV)+6)>246
SET APCLSTP=1
SET APCLV=APCLV_" ...etc."
End DoDot:2
IF $GET(APCLSTP)
QUIT
SET APCLV=$SELECT(APCLI>1:APCLV_", ",1:$GET(APCLV))_$PIECE(APCLDF(APCLI),U,2)
+19 KILL APCLDF,APCLPCE
End DoDot:1
+20 QUIT
+21 ;
SET ; Set Value and or Date from PCC SCRIPT
+1 ;beginning Y2K fix. Modified line to use a 4 digit year rather than a 2 digit year. Not sure is this was necessary but it will work either way.
+2 ;S Y=$P(APCLDF(APCLI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$S(APCLDIS="BOTH":$P(APCLDF(APCLI),U,2)_" - "_Y,1:Y)
+3 ;Y2000
SET Y=$PIECE(APCLDF(APCLI),U)
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
SET APCLV=$SELECT(APCLI>1:APCLV_", ",1:$GET(APCLV))_$SELECT(APCLDIS="BOTH":$PIECE(APCLDF(APCLI),U,2)_" - "_Y,1:Y)
+4 ;end Y2K fix
+5 QUIT
+6 ;
APCLWRTE ; Write line
+1 IF APCLWRTE(1)="@"
IF $DATA(APCLBRK)
DO PAGE
GOTO X1
+2 IF APCLWRTE(1)="@"
WRITE @IOF
SET APCLCNT=0
GOTO X1
+3 FOR APCLX=1:1:APCLL
IF APCLSTP
QUIT
WRITE !,APCLWRTE(APCLX)
SET APCLCNT=APCLCNT+1
IF $DATA(APCLBRK)
IF (IOSL-3)<APCLCNT
DO PAGE
X2 KILL APCLWRTE
+1 QUIT
+2 ;
PAGE ; Page Control
+1 WRITE !
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 IF Y
SET APCLCNT=0
+4 IF '$TEST
SET APCLSTP=1
+5 WRITE @IOF
+6 QUIT
+7 ;
PCT ; Determine APCL
+1 SET @("APCLV="_APCLV)
+2 SET APCLV=APCLV*100
SET APCLV=$JUSTIFY(APCLV,3,0)_"%"
X1 QUIT
+1 ;
