BDMD919 ; IHS/CMI/LAB - 2009 DIABETES AUDIT ; 21 Jan 2014 10:55 AM
;;2.0;DIABETES MANAGEMENT SYSTEM;**2,3,4,5,6,7,8,9,10**;JUN 14, 2007;Build 12
;
;
W:$D(IOF) @IOF
W !!,"Checking for Taxonomies to support the 2009 Audit. ",!,"Please enter the device for printing.",!
ZIS ;
S XBRC="",XBRP="TAXCHK^BDMD919",XBNS="",XBRX="XIT^BDMD919"
D ^XBDBQUE
D XIT
Q
TAXCHK ;EP - called by gui
;D HOME^%ZIS
K BDMQUIT
GUICHK ;EP
NEW A,BDMX,I,Y,Z,J,BDMY,BDMT
K A
S BDMYR=$O(^BDMTAXS("B",2009,0))
S BDMT=0 F S BDMT=$O(^BDMTAXS(BDMYR,11,BDMT)) Q:BDMT'=+BDMT D
.S BDMY=$G(^BDMTAXS(BDMYR,11,BDMT,0))
.S BDMTN=$P(BDMY,U,1)
.S BDMFILE=$P(BDMY,U,2)
.S BDMTYPE=$P(^DIC($P(BDMY,U,2),0),U)
.S Y=BDMTYPE_" taxonomy "
.I BDMFILE'=60 D
..I '$D(^ATXAX("B",BDMTN)) S A(BDMTN)=Y_"^is Missing" Q
..S I=$O(^ATXAX("B",BDMTN,0))
..I '$D(^ATXAX(I,21,"B")) S A(BDMTN)=Y_"^has no entries "
.I BDMFILE=60 D
..I '$D(^ATXLAB("B",BDMTN)) S A(BDMTN)=Y_"^is Missing " Q
..S I=$O(^ATXLAB("B",BDMTN,0))
..I '$D(^ATXLAB(I,21,"B")) S A(BDMTN)=Y_"^has no entries "
..;check for panels and warn
..I '$P(^ATXLAB(I,0),U,11) D
...S BDMY=0 F S BDMY=$O(^ATXLAB(I,21,"B",BDMY)) Q:BDMY'=+BDMY D
....I $O(^LAB(60,BDMY,2,0)) S A(BDMTN)=Y_"^contains a panel test: "_$P(^LAB(60,BDMY,0),U)_" and should not."
I '$D(A) W !,"All taxonomies are present.",! K A,BDMX,BDMT,BDMY,Y,I,Z D DONE Q
W !!,"In order for the 2009 DM AUDIT Report to find all necessary data, several",!,"taxonomies must be established. The following taxonomies are missing or have",!,"no entries:"
S BDMX="" F S BDMX=$O(A(BDMX)) Q:BDMX=""!($D(BDMQUIT)) D
.;I $Y>(IOSL-2) D PAGE Q:$D(BDMQUIT)
.W !,$P(A(BDMX),U)," [",BDMX,"] ",$P(A(BDMX),U,2)
.Q
DONE ;
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of taxonomy check. HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
XIT ;EP
K BDM,BDMX,BDMQUIT,BDMLINE,BDMJ,BDMX,BDMTEXT,BDM
K X,Y,J
Q
LASTHF(P,C,BDATE,EDATE,F) ;EP - get last factor in category C for patient P
I '$G(P) Q ""
I $G(C)="" Q ""
I $G(F)="" S F=""
S C=$O(^AUTTHF("B",C,0)) ;ien of category passed
I '$G(C) Q ""
NEW H,D,O S H=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
. Q:'$D(^AUPNVHF("AA",P,H))
. S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
.. Q:(9999999-D)>EDATE ;after time frame
.. Q:(9999999-D)<BDATE ;before time frame
.. S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
. Q
S D=$O(O(0))
I D="" Q D
I F="F" Q $P(^AUTTHF($P(^AUPNVHF(O(D),0),U),0),U)
;
Q 1
;;
BANNER ;EP - banner for 2009 audit menu
S BDMTEXT="TEXTD",BDM("VERSION")="2.0 (Patch 10)"
F BDMJ=1:1 S BDMX=$T(@BDMTEXT+BDMJ),BDMX=$P(BDMX,";;",2) Q:BDMX="QUIT"!(BDMX="") S BDMLINE=BDMJ
PRINT D ^XBCLS W:$D(IOF) @IOF
F BDMJ=1:1:BDMLINE S BDMX=$T(@BDMTEXT+BDMJ),BDMX=$P(BDMX,";;",2) W !?80-$L(BDMX)\2,BDMX K BDMX
W !?80-(8+$L(BDM("VERSION")))/2,"Version ",BDM("VERSION")
G XIT:'$D(DUZ(2)) G:'DUZ(2) XIT S BDM("SITE")=$P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),"^") W !!?80-$L(BDM("SITE"))\2,BDM("SITE")
D XIT
Q
TEXTD ;EP
;;****************************************
;;** DIABETES MANAGEMENT SYSTEM **
;;** 2009 Diabetes Audit Report Menu **
;;****************************************
;;QUIT
PAGE ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BDMQUIT="" Q
Q
BMIEPI(H,W) ;EP ;
NEW %
I H="" Q ""
I W="" Q ""
I 'H Q ""
S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
Q %
BDMD919 ; IHS/CMI/LAB - 2009 DIABETES AUDIT ; 21 Jan 2014 10:55 AM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2,3,4,5,6,7,8,9,10**;JUN 14, 2007;Build 12
+2 ;
+3 ;
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !!,"Checking for Taxonomies to support the 2009 Audit. ",!,"Please enter the device for printing.",!
ZIS ;
+1 SET XBRC=""
SET XBRP="TAXCHK^BDMD919"
SET XBNS=""
SET XBRX="XIT^BDMD919"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
TAXCHK ;EP - called by gui
+1 ;D HOME^%ZIS
+2 KILL BDMQUIT
GUICHK ;EP
+1 NEW A,BDMX,I,Y,Z,J,BDMY,BDMT
+2 KILL A
+3 SET BDMYR=$ORDER(^BDMTAXS("B",2009,0))
+4 SET BDMT=0
FOR
SET BDMT=$ORDER(^BDMTAXS(BDMYR,11,BDMT))
IF BDMT'=+BDMT
QUIT
Begin DoDot:1
+5 SET BDMY=$GET(^BDMTAXS(BDMYR,11,BDMT,0))
+6 SET BDMTN=$PIECE(BDMY,U,1)
+7 SET BDMFILE=$PIECE(BDMY,U,2)
+8 SET BDMTYPE=$PIECE(^DIC($PIECE(BDMY,U,2),0),U)
+9 SET Y=BDMTYPE_" taxonomy "
+10 IF BDMFILE'=60
Begin DoDot:2
+11 IF '$DATA(^ATXAX("B",BDMTN))
SET A(BDMTN)=Y_"^is Missing"
QUIT
+12 SET I=$ORDER(^ATXAX("B",BDMTN,0))
+13 IF '$DATA(^ATXAX(I,21,"B"))
SET A(BDMTN)=Y_"^has no entries "
End DoDot:2
+14 IF BDMFILE=60
Begin DoDot:2
+15 IF '$DATA(^ATXLAB("B",BDMTN))
SET A(BDMTN)=Y_"^is Missing "
QUIT
+16 SET I=$ORDER(^ATXLAB("B",BDMTN,0))
+17 IF '$DATA(^ATXLAB(I,21,"B"))
SET A(BDMTN)=Y_"^has no entries "
+18 ;check for panels and warn
+19 IF '$PIECE(^ATXLAB(I,0),U,11)
Begin DoDot:3
+20 SET BDMY=0
FOR
SET BDMY=$ORDER(^ATXLAB(I,21,"B",BDMY))
IF BDMY'=+BDMY
QUIT
Begin DoDot:4
+21 IF $ORDER(^LAB(60,BDMY,2,0))
SET A(BDMTN)=Y_"^contains a panel test: "_$PIECE(^LAB(60,BDMY,0),U)_" and should not."
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF '$DATA(A)
WRITE !,"All taxonomies are present.",!
KILL A,BDMX,BDMT,BDMY,Y,I,Z
DO DONE
QUIT
+23 WRITE !!,"In order for the 2009 DM AUDIT Report to find all necessary data, several",!,"taxonomies must be established. The following taxonomies are missing or have",!,"no entries:"
+24 SET BDMX=""
FOR
SET BDMX=$ORDER(A(BDMX))
IF BDMX=""!($DATA(BDMQUIT))
QUIT
Begin DoDot:1
+25 ;I $Y>(IOSL-2) D PAGE Q:$D(BDMQUIT)
+26 WRITE !,$PIECE(A(BDMX),U)," [",BDMX,"] ",$PIECE(A(BDMX),U,2)
+27 QUIT
End DoDot:1
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of taxonomy check. HIT RETURN"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
XIT ;EP
+1 KILL BDM,BDMX,BDMQUIT,BDMLINE,BDMJ,BDMX,BDMTEXT,BDM
+2 KILL X,Y,J
+3 QUIT
LASTHF(P,C,BDATE,EDATE,F) ;EP - get last factor in category C for patient P
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(C)=""
QUIT ""
+3 IF $GET(F)=""
SET F=""
+4 ;ien of category passed
SET C=$ORDER(^AUTTHF("B",C,0))
+5 IF '$GET(C)
QUIT ""
+6 NEW H,D,O
SET H=0
KILL O
+7 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+9 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+10 ;after time frame
IF (9999999-D)>EDATE
QUIT
+11 ;before time frame
IF (9999999-D)<BDATE
QUIT
+12 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET D=$ORDER(O(0))
+15 IF D=""
QUIT D
+16 IF F="F"
QUIT $PIECE(^AUTTHF($PIECE(^AUPNVHF(O(D),0),U),0),U)
+17 ;
+18 QUIT 1
+19 ;;
BANNER ;EP - banner for 2009 audit menu
+1 SET BDMTEXT="TEXTD"
SET BDM("VERSION")="2.0 (Patch 10)"
+2 FOR BDMJ=1:1
SET BDMX=$TEXT(@BDMTEXT+BDMJ)
SET BDMX=$PIECE(BDMX,";;",2)
IF BDMX="QUIT"!(BDMX="")
QUIT
SET BDMLINE=BDMJ
PRINT DO ^XBCLS
IF $DATA(IOF)
WRITE @IOF
+1 FOR BDMJ=1:1:BDMLINE
SET BDMX=$TEXT(@BDMTEXT+BDMJ)
SET BDMX=$PIECE(BDMX,";;",2)
WRITE !?80-$LENGTH(BDMX)\2,BDMX
KILL BDMX
+2 WRITE !?80-(8+$LENGTH(BDM("VERSION")))/2,"Version ",BDM("VERSION")
+3 IF '$DATA(DUZ(2))
GOTO XIT
IF 'DUZ(2)
GOTO XIT
SET BDM("SITE")=$PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),"^")
WRITE !!?80-$LENGTH(BDM("SITE"))\2,BDM("SITE")
+4 DO XIT
+5 QUIT
TEXTD ;EP
+1 ;;****************************************
+2 ;;** DIABETES MANAGEMENT SYSTEM **
+3 ;;** 2009 Diabetes Audit Report Menu **
+4 ;;****************************************
+5 ;;QUIT
PAGE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BDMQUIT=""
QUIT
+2 QUIT
BMIEPI(H,W) ;EP ;
+1 NEW %
+2 IF H=""
QUIT ""
+3 IF W=""
QUIT ""
+4 IF 'H
QUIT ""
+5 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+6 QUIT %
