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 ;
