- BDMPRT ; IHS/CMI/LAB - PRINTS REPORTS USING REPORT TEMPLATE FILE ;
- ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
- ;
- ;CMI/TUCSON/LAB - patch 3 - 10/26/1998 - Y2K fixes
- EN(BDMDFN,BDMROOT,BDMPD) ;PEP - create report
- I '$D(BDMROOT) W !,*7,"Global root not indicated!" Q
- I '$D(ZTQUEUED),$P(IOST,"-")="C" S BDMBRK="" W @IOF
- S BDMENDR=$E(BDMROOT,$L(BDMROOT)) I "(,"[BDMENDR S BDMROOT=$E(BDMROOT,1,($L(BDMROOT)-1))
- S BDMENDR=$E(BDMROOT,$L(BDMROOT)) I BDMENDR'=")",BDMROOT["(" S BDMROOT=BDMROOT_")"
- S (BDMOOP,BDMCNT,BDMSTP)=0 F S BDMOOP=$O(^APCLRPT(BDMDFN,21,BDMOOP)) Q:'BDMOOP!BDMSTP S BDML=0 S BDMLINE=^(BDMOOP,0) D D BDMWRTE
- . F I=1:1 Q:$P(BDMLINE,"|",2,99)="" S BDMN=+$P(BDMLINE,"|",2),BDMTMP=$P(BDMLINE,"|") S BDMV=$S($D(@BDMROOT@(BDMN)):@BDMROOT@(BDMN),1:"") D:BDMV="" CODE D:BDMV]""&($P($G(^APCLRPT(BDMDFN,31,BDMN,0)),U,2)="p") PCT D K BDMCODE
- .. I ($L(BDMTMP)+$L(BDMV))>$S($D(BDMCODE):250,1:IOM) S BDML=BDML+1 S BDMWRTE(BDML)=BDMTMP S BDMLINE=BDMV_$P(BDMLINE,"|",3,999) Q
- .. S BDMTMP=BDMTMP_BDMV
- .. I ($L(BDMTMP)+$L($P(BDMLINE,"|",3,999)))>IOM S BDML=BDML+1 S BDMWRTE(BDML)=BDMTMP S BDMLINE=$P(BDMLINE,"|",3,999) Q
- .. S BDMLINE=BDMTMP_$P(BDMLINE,"|",3,999)
- . S BDML=BDML+1 S BDMWRTE(BDML)=BDMLINE
- I $D(BDMBRK),'BDMSTP D PAGE I 1
- E W @IOF
- K BDMOOP,BDMBRK,BDMCNT,BDMI,BDMTMP,BDML,BDMLINE,BDMN,BDMV,BDMWRTE,BDMX,BDMENDR
- I '$D(BDMASK) K BDMSTP
- Q
- ;
- CODE ; Get date or value from data fetcher
- NEW BDMDIS,BDMI,BDMSTP
- K BDMER
- I $G(BDMPD),$G(^APCLRPT(BDMDFN,31,BDMN,21))]"" S BDMCODE=^(21) D
- . I BDMCODE["*" S BDMV="Script error - '*' entered as a value!" Q
- . I $G(BDMDATE)]"",$P(BDMCODE,";",2)]"" S BDMV="Script error - date information entered!" Q
- . S BDMDIS=$S($P(BDMCODE," ")="DATE":"DATE",$P(BDMCODE," ")="VALUE"!("PATPT"[$P(BDMCODE," ")):"VALUE",1:"BOTH")
- . I $E($P(BDMCODE," "),1,3)["PAT"!($E($P(BDMCODE," "),1,2)["PT")
- . E I BDMDIS="DATE"!(BDMDIS="VALUE") S BDMCODE=$P(BDMCODE," ",2,99)
- . I $E($P(BDMCODE," "),1,3)'="PAT",$E($P(BDMCODE," "),1,2)'="PT" S BDMCODE=BDMCODE_$G(BDMDATE)
- . S BDMX=BDMPD_"^"_BDMCODE,BDMY="BDMDF(" S BDMER=$$START1^APCLDF(BDMX,BDMY) K BDMX,BDMY
- . I BDMER S BDMV="Data Retrieval Error!" K BDMER Q
- . K BDMER
- . I '$D(BDMDF) S BDMV="None Found" K BDMDF Q
- . I BDMDIS="BOTH"!(BDMDIS="DATE") F BDMI=1:1 Q:'$D(BDMDF(BDMI)) D Q:$G(BDMSTP) D SET
- .. I ($L(BDMV)+6)>246 S BDMSTP=1,BDMV=BDMV_" ...etc."
- . I BDMDIS'="VALUE" K BDMDF Q
- . F BDMI=1:1 Q:'$D(BDMDF(BDMI)) D Q:$G(BDMSTP) S BDMV=$S(BDMI>1:BDMV_", ",1:$G(BDMV))_$P(BDMDF(BDMI),U,2)
- .. I ($L(BDMV)+6)>246 S BDMSTP=1,BDMV=BDMV_" ...etc."
- . K BDMDF,BDMPCE
- 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(BDMDF(BDMI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S BDMV=$S(BDMI>1:BDMV_", ",1:$G(BDMV))_$S(BDMDIS="BOTH":$P(BDMDF(BDMI),U,2)_" - "_Y,1:Y)
- S Y=$P(BDMDF(BDMI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3)) S BDMV=$S(BDMI>1:BDMV_", ",1:$G(BDMV))_$S(BDMDIS="BOTH":$P(BDMDF(BDMI),U,2)_" - "_Y,1:Y) ;Y2000
- ;end Y2K fix
- Q
- ;
- BDMWRTE ; Write line
- I BDMWRTE(1)="@",$D(BDMBRK) D PAGE G X1
- I BDMWRTE(1)="@" W @IOF S BDMCNT=0 G X1
- F BDMX=1:1:BDML Q:BDMSTP W !,BDMWRTE(BDMX) S BDMCNT=BDMCNT+1 I $D(BDMBRK),(IOSL-3)<BDMCNT D PAGE
- X2 K BDMWRTE
- Q
- ;
- PAGE ; Page Control
- W !
- S DIR(0)="E" D ^DIR K DIR
- I Y S BDMCNT=0
- E S BDMSTP=1
- W @IOF
- Q
- ;
- PCT ; Determine BDM
- S @("BDMV="_BDMV)
- S BDMV=BDMV*100,BDMV=$J(BDMV,3,0)_"%"
- X1 Q
- ;
- BDMPRT ; IHS/CMI/LAB - PRINTS REPORTS USING REPORT TEMPLATE FILE ;
- +1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
- +2 ;
- +3 ;CMI/TUCSON/LAB - patch 3 - 10/26/1998 - Y2K fixes
- EN(BDMDFN,BDMROOT,BDMPD) ;PEP - create report
- +1 IF '$DATA(BDMROOT)
- WRITE !,*7,"Global root not indicated!"
- QUIT
- +2 IF '$DATA(ZTQUEUED)
- IF $PIECE(IOST,"-")="C"
- SET BDMBRK=""
- WRITE @IOF
- +3 SET BDMENDR=$EXTRACT(BDMROOT,$LENGTH(BDMROOT))
- IF "(,"[BDMENDR
- SET BDMROOT=$EXTRACT(BDMROOT,1,($LENGTH(BDMROOT)-1))
- +4 SET BDMENDR=$EXTRACT(BDMROOT,$LENGTH(BDMROOT))
- IF BDMENDR'=")"
- IF BDMROOT["("
- SET BDMROOT=BDMROOT_")"
- +5 SET (BDMOOP,BDMCNT,BDMSTP)=0
- FOR
- SET BDMOOP=$ORDER(^APCLRPT(BDMDFN,21,BDMOOP))
- IF 'BDMOOP!BDMSTP
- QUIT
- SET BDML=0
- SET BDMLINE=^(BDMOOP,0)
- Begin DoDot:1
- +6 FOR I=1:1
- IF $PIECE(BDMLINE,"|",2,99)=""
- QUIT
- SET BDMN=+$PIECE(BDMLINE,"|",2)
- SET BDMTMP=$PIECE(BDMLINE,"|")
- SET BDMV=$SELECT($DATA(@BDMROOT@(BDMN)):@BDMROOT@(BDMN),1:"")
- IF BDMV=""
- DO CODE
- IF BDMV]""&($PIECE($GET(^APCLRPT(BDMDFN,31,BDMN,0)),U,2)="p")
- DO PCT
- Begin DoDot:2
- +7 IF ($LENGTH(BDMTMP)+$LENGTH(BDMV))>$SELECT($DATA(BDMCODE):250,1:IOM)
- SET BDML=BDML+1
- SET BDMWRTE(BDML)=BDMTMP
- SET BDMLINE=BDMV_$PIECE(BDMLINE,"|",3,999)
- QUIT
- +8 SET BDMTMP=BDMTMP_BDMV
- +9 IF ($LENGTH(BDMTMP)+$LENGTH($PIECE(BDMLINE,"|",3,999)))>IOM
- SET BDML=BDML+1
- SET BDMWRTE(BDML)=BDMTMP
- SET BDMLINE=$PIECE(BDMLINE,"|",3,999)
- QUIT
- +10 SET BDMLINE=BDMTMP_$PIECE(BDMLINE,"|",3,999)
- End DoDot:2
- KILL BDMCODE
- +11 SET BDML=BDML+1
- SET BDMWRTE(BDML)=BDMLINE
- End DoDot:1
- DO BDMWRTE
- +12 IF $DATA(BDMBRK)
- IF 'BDMSTP
- DO PAGE
- IF 1
- +13 IF '$TEST
- WRITE @IOF
- +14 KILL BDMOOP,BDMBRK,BDMCNT,BDMI,BDMTMP,BDML,BDMLINE,BDMN,BDMV,BDMWRTE,BDMX,BDMENDR
- +15 IF '$DATA(BDMASK)
- KILL BDMSTP
- +16 QUIT
- +17 ;
- CODE ; Get date or value from data fetcher
- +1 NEW BDMDIS,BDMI,BDMSTP
- +2 KILL BDMER
- +3 IF $GET(BDMPD)
- IF $GET(^APCLRPT(BDMDFN,31,BDMN,21))]""
- SET BDMCODE=^(21)
- Begin DoDot:1
- +4 IF BDMCODE["*"
- SET BDMV="Script error - '*' entered as a value!"
- QUIT
- +5 IF $GET(BDMDATE)]""
- IF $PIECE(BDMCODE,";",2)]""
- SET BDMV="Script error - date information entered!"
- QUIT
- +6 SET BDMDIS=$SELECT($PIECE(BDMCODE," ")="DATE":"DATE",$PIECE(BDMCODE," ")="VALUE"!("PATPT"[$PIECE(BDMCODE," ")):"VALUE",1:"BOTH")
- +7 IF $EXTRACT($PIECE(BDMCODE," "),1,3)["PAT"!($EXTRACT($PIECE(BDMCODE," "),1,2)["PT")
- +8 IF '$TEST
- IF BDMDIS="DATE"!(BDMDIS="VALUE")
- SET BDMCODE=$PIECE(BDMCODE," ",2,99)
- +9 IF $EXTRACT($PIECE(BDMCODE," "),1,3)'="PAT"
- IF $EXTRACT($PIECE(BDMCODE," "),1,2)'="PT"
- SET BDMCODE=BDMCODE_$GET(BDMDATE)
- +10 SET BDMX=BDMPD_"^"_BDMCODE
- SET BDMY="BDMDF("
- SET BDMER=$$START1^APCLDF(BDMX,BDMY)
- KILL BDMX,BDMY
- +11 IF BDMER
- SET BDMV="Data Retrieval Error!"
- KILL BDMER
- QUIT
- +12 KILL BDMER
- +13 IF '$DATA(BDMDF)
- SET BDMV="None Found"
- KILL BDMDF
- QUIT
- +14 IF BDMDIS="BOTH"!(BDMDIS="DATE")
- FOR BDMI=1:1
- IF '$DATA(BDMDF(BDMI))
- QUIT
- Begin DoDot:2
- +15 IF ($LENGTH(BDMV)+6)>246
- SET BDMSTP=1
- SET BDMV=BDMV_" ...etc."
- End DoDot:2
- IF $GET(BDMSTP)
- QUIT
- DO SET
- +16 IF BDMDIS'="VALUE"
- KILL BDMDF
- QUIT
- +17 FOR BDMI=1:1
- IF '$DATA(BDMDF(BDMI))
- QUIT
- Begin DoDot:2
- +18 IF ($LENGTH(BDMV)+6)>246
- SET BDMSTP=1
- SET BDMV=BDMV_" ...etc."
- End DoDot:2
- IF $GET(BDMSTP)
- QUIT
- SET BDMV=$SELECT(BDMI>1:BDMV_", ",1:$GET(BDMV))_$PIECE(BDMDF(BDMI),U,2)
- +19 KILL BDMDF,BDMPCE
- 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(BDMDF(BDMI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S BDMV=$S(BDMI>1:BDMV_", ",1:$G(BDMV))_$S(BDMDIS="BOTH":$P(BDMDF(BDMI),U,2)_" - "_Y,1:Y)
- +3 ;Y2000
- SET Y=$PIECE(BDMDF(BDMI),U)
- SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
- SET BDMV=$SELECT(BDMI>1:BDMV_", ",1:$GET(BDMV))_$SELECT(BDMDIS="BOTH":$PIECE(BDMDF(BDMI),U,2)_" - "_Y,1:Y)
- +4 ;end Y2K fix
- +5 QUIT
- +6 ;
- BDMWRTE ; Write line
- +1 IF BDMWRTE(1)="@"
- IF $DATA(BDMBRK)
- DO PAGE
- GOTO X1
- +2 IF BDMWRTE(1)="@"
- WRITE @IOF
- SET BDMCNT=0
- GOTO X1
- +3 FOR BDMX=1:1:BDML
- IF BDMSTP
- QUIT
- WRITE !,BDMWRTE(BDMX)
- SET BDMCNT=BDMCNT+1
- IF $DATA(BDMBRK)
- IF (IOSL-3)<BDMCNT
- DO PAGE
- X2 KILL BDMWRTE
- +1 QUIT
- +2 ;
- PAGE ; Page Control
- +1 WRITE !
- +2 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +3 IF Y
- SET BDMCNT=0
- +4 IF '$TEST
- SET BDMSTP=1
- +5 WRITE @IOF
- +6 QUIT
- +7 ;
- PCT ; Determine BDM
- +1 SET @("BDMV="_BDMV)
- +2 SET BDMV=BDMV*100
- SET BDMV=$JUSTIFY(BDMV,3,0)_"%"
- X1 QUIT
- +1 ;
