- 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 ;
