BDMDFTV ; IHS/CMI/LAB - DISPLAY IND LISTS ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**11**;JUN 14, 2007;Build 30
;; ;
EP ;EP - CALLED FROM OPTION
D EN
Q
EOJ ;EP
I '$D(BDMGUI) D EN^XBVK("BDM")
Q
;; ;
EN ;EP -- main entry point for
D EN^VALM("BDMDF TAXONOMY VIEW")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
PAUSE ;EP
Q:$E(IOST)'="C"!(IO'=IO(0))
W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
HDR ; -- header code
S VALMHDR(1)="TAXONOMIES TO SUPPORT 2018 DIABETES/PRE-DIABETES AUDIT REPORTING"
S VALMHDR(2)="* View Taxonomies"
Q
;
INIT ;EP -- init variables and list array
K BDMTAX S BDMHIGH="",C=0
S BDMYR=$O(^BDMTAXS("B",2018,0))
S BDMX=0,J=0 F S BDMX=$O(^BDMTAXS(BDMYR,11,"B",BDMX)) Q:BDMX="" D
.S BDMY=$O(^BDMTAXS(BDMYR,11,"B",BDMX,0))
.;Q:'$P(^BDMTAXS(BDMYR,11,BDMY,0),U,5)
.S Y=$P(^DIC($P(^BDMTAXS(BDMYR,11,BDMY,0),U,2),0),U)
.S J=J+1
.S BDMTAX(J,0)=J_") "_BDMX,$E(BDMTAX(J,0),38)=$E(Y,1,30)
.I $P(^BDMTAXS(BDMYR,11,BDMY,0),U,2)'=60 S I=$O(^ATXAX("B",BDMX,0))
.I $P(^BDMTAXS(BDMYR,11,BDMY,0),U,2)=60 S I=$O(^ATXLAB("B",BDMX,0))
.S BDMTAX("IDX",J,J)=I_U_$S($P(^BDMTAXS(BDMYR,11,BDMY,0),U,2)=60:"L",1:"T")
.S C=C+1
.Q
S (VALMCNT,BDMHIGH)=C
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
DISP ;EP - add an item to the selected list - called from a protocol
W !
S DIR(0)="NO^1:"_BDMHIGH,DIR("A")="Which Taxonomy"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No taxonomy selected." G DISPX
I $D(DIRUT) W !,"No taxonomy selected." G DISPX
S BDMTAXI=$P(BDMTAX("IDX",Y,Y),U,1),BDMTAXT=$P(BDMTAX("IDX",Y,Y),U,2)
;BROWSE OR PRINT
D FULL^VALM1
W ! S DIR(0)="S^P:PRINT Taxonomy Output;B:BROWSE Taxonomy Output on Screen",DIR("A")="Do you wish to",DIR("B")="B" K DA D ^DIR K DIR
I $D(DIRUT) D XIT Q
S BDMOPT=Y
I Y="B" D BROWSE,XIT Q
S XBRP="PRINT^BDMDFTV",XBRC="",XBRX="XIT^BDMDFTV",XBNS="BDM"
D ^XBDBQUE
D DISPX
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^BDMDFTV"")"
S XBRC="",XBRX="XIT^BDMDFTV",XBIOP=0 D ^XBDBQUE
Q
PHDR ;
I 'BDMPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BDMQ="" Q
HEAD1 ;
I BDMPG W:$D(IOF) @IOF
S BDMPG=BDMPG+1
I $G(BDMGUI),BDMPG'=1 W !,"ZZZZZZZ"
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!
W ?(80-$L($P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!
W $$CTR("Listing of the "_BDMTAXN_" taxonomy",80),!,BDM80D,!
Q
PRINT ;
S BDMPG=0
K BDMQ
I BDMTAXT="L" S BDMTAXN=$P(^ATXLAB(BDMTAXI,0),U,1)
I BDMTAXT="T" S BDMTAXN=$P(^ATXAX(BDMTAXI,0),U,1)
S BDM80D="-------------------------------------------------------------------------------"
D PHDR
I BDMTAXT'="L" S BDMFILE=$P(^ATXAX(BDMTAXI,0),U,15)
I BDMTAXT="L" S BDMFILE=60
P1 K ^TMP($J,"BDMTAXDSP")
I BDMTAXT="L" D G P11
.S X="" F S X=$O(^ATXLAB(BDMTAXI,21,"B",X)) Q:X="" D
..S ^TMP($J,"BDMTAXDSP",X)=""
S F=$NA(^TMP($J,"BDMTAXDSP"))
I BDMFILE'=50.67,BDMFILE'=9999999.64,BDMFILE'=95.3,BDMFILE'=60,BDMFILE'=9999999.14 D BLDTAX^ATXAPI(BDMTAXN,F,$O(^ATXAX("B",BDMTAXN,0))) I 1
E S BDMX="" F S BDMX=$O(^ATXAX(BDMTAXI,21,"B",BDMX)) Q:BDMX="" S ^TMP($J,"BDMTAXDSP",BDMX)=""
S BDMFILE=$P(^ATXAX(BDMTAXI,0),U,15)
P11 S BDMX="" F S BDMX=$O(^TMP($J,"BDMTAXDSP",BDMX)) Q:BDMX="" D
.S (BDM1,BDM2,BDMF,BDM3,BDMC2,BDMC3)=""
.S BDMC2=35,BDMC3=65
.I BDMFILE=80 S D=$$ICDDX^ICDEX(BDMX,DT,,"I") S BDM1=$P(D,U,2),BDM2=$E($P(D,U,4),1,50),BDM3=$P(D,U,20),BDM3=$P(^ICDS(BDM3,0),U,1),BDMC2=15,BDMC3=65
.I BDMFILE=80.1 S D=$$ICDOP^ICDEX(BDMX,DT,,"I") S BDM1=$P(D,U,2),BDM2=$E($P(D,U,5),1,50),BDM3=$P(D,U,15),BDM3=$P(^ICDS(BDM3,0),U,1),BDMC2=15,BDMC3=65
.I BDMFILE=81 S D=$$CPT^ICPTCOD(BDMX) S BDM1=$P(D,U,2),BDM2=$P(D,U,3),BDMC2=15
.I BDMFILE=50.67 S BDM1=BDMX,BDM2=$O(^PSNDF(50.67,"NDC",$$STRIP^XLFSTR(BDM1,"-"),0)) I BDM2 S BDM2=$$GET1^DIQ(50.67,BDM2,4)
.I BDMFILE=9999999.64 S BDM1=$$GET1^DIQ(BDMFILE,BDMX,.01)
.I BDMFILE=9999999.09 S BDM1=$$GET1^DIQ(BDMFILE,BDMX,.01),BDM2=$$GET1^DIQ(BDMFILE,BDMX,1),BDMC2=50
.I BDMFILE=9999999.14 S BDM1=BDMX S %=$O(^AUTTIMM("C",BDMX,0)) I % S BDM2=$$GET1^DIQ(BDMFILE,%,.01),BDMC2=15
.I BDMFILE=95.3 S BDM1=BDMX S %=$O(^LAB(95.3,"B",$P(BDMX,"-"),0)) I % S BDM2=$$GET1^DIQ(95.3,%,80),BDMC2=15
.I BDM1="" D
..S BDMF=".01"
..S BDM1=$$GET1^DIQ(BDMFILE,BDMX,.01)
.I $Y>(IOSL-3) D PHDR Q:$D(BDMQ)
.W BDM1,?BDMC2,$E(BDM2,1,40),?BDMC3,BDM3,!
D XIT
Q
DISPX ;
D BACK
Q
XIT ;
K ^TMP($J,"BDMTAXDSP")
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
BDMDFTV ; IHS/CMI/LAB - DISPLAY IND LISTS ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**11**;JUN 14, 2007;Build 30
+2 ;; ;
EP ;EP - CALLED FROM OPTION
+1 DO EN
+2 QUIT
EOJ ;EP
+1 IF '$DATA(BDMGUI)
DO EN^XBVK("BDM")
+2 QUIT
+3 ;; ;
EN ;EP -- main entry point for
+1 DO EN^VALM("BDMDF TAXONOMY VIEW")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 IF $DATA(IOF)
WRITE @IOF
+5 DO EOJ
+6 QUIT
+7 ;
PAUSE ;EP
+1 IF $EXTRACT(IOST)'="C"!(IO'=IO(0))
QUIT
+2 WRITE !
SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 QUIT
HDR ; -- header code
+1 SET VALMHDR(1)="TAXONOMIES TO SUPPORT 2018 DIABETES/PRE-DIABETES AUDIT REPORTING"
+2 SET VALMHDR(2)="* View Taxonomies"
+3 QUIT
+4 ;
INIT ;EP -- init variables and list array
+1 KILL BDMTAX
SET BDMHIGH=""
SET C=0
+2 SET BDMYR=$ORDER(^BDMTAXS("B",2018,0))
+3 SET BDMX=0
SET J=0
FOR
SET BDMX=$ORDER(^BDMTAXS(BDMYR,11,"B",BDMX))
IF BDMX=""
QUIT
Begin DoDot:1
+4 SET BDMY=$ORDER(^BDMTAXS(BDMYR,11,"B",BDMX,0))
+5 ;Q:'$P(^BDMTAXS(BDMYR,11,BDMY,0),U,5)
+6 SET Y=$PIECE(^DIC($PIECE(^BDMTAXS(BDMYR,11,BDMY,0),U,2),0),U)
+7 SET J=J+1
+8 SET BDMTAX(J,0)=J_") "_BDMX
SET $EXTRACT(BDMTAX(J,0),38)=$EXTRACT(Y,1,30)
+9 IF $PIECE(^BDMTAXS(BDMYR,11,BDMY,0),U,2)'=60
SET I=$ORDER(^ATXAX("B",BDMX,0))
+10 IF $PIECE(^BDMTAXS(BDMYR,11,BDMY,0),U,2)=60
SET I=$ORDER(^ATXLAB("B",BDMX,0))
+11 SET BDMTAX("IDX",J,J)=I_U_$SELECT($PIECE(^BDMTAXS(BDMYR,11,BDMY,0),U,2)=60:"L",1:"T")
+12 SET C=C+1
+13 QUIT
End DoDot:1
+14 SET (VALMCNT,BDMHIGH)=C
+15 QUIT
+16 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
BACK ;go back to listman
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
DISP ;EP - add an item to the selected list - called from a protocol
+1 WRITE !
+2 SET DIR(0)="NO^1:"_BDMHIGH
SET DIR("A")="Which Taxonomy"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !,"No taxonomy selected."
GOTO DISPX
+5 IF $DATA(DIRUT)
WRITE !,"No taxonomy selected."
GOTO DISPX
+6 SET BDMTAXI=$PIECE(BDMTAX("IDX",Y,Y),U,1)
SET BDMTAXT=$PIECE(BDMTAX("IDX",Y,Y),U,2)
+7 ;BROWSE OR PRINT
+8 DO FULL^VALM1
+9 WRITE !
SET DIR(0)="S^P:PRINT Taxonomy Output;B:BROWSE Taxonomy Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="B"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
DO XIT
QUIT
+11 SET BDMOPT=Y
+12 IF Y="B"
DO BROWSE
DO XIT
QUIT
+13 SET XBRP="PRINT^BDMDFTV"
SET XBRC=""
SET XBRX="XIT^BDMDFTV"
SET XBNS="BDM"
+14 DO ^XBDBQUE
+15 DO DISPX
+16 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^BDMDFTV"")"
+2 SET XBRC=""
SET XBRX="XIT^BDMDFTV"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
PHDR ;
+1 IF 'BDMPG
GOTO HEAD1
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BDMQ=""
QUIT
HEAD1 ;
+1 IF BDMPG
IF $DATA(IOF)
WRITE @IOF
+2 SET BDMPG=BDMPG+1
+3 IF $GET(BDMGUI)
IF BDMPG'=1
WRITE !,"ZZZZZZZ"
+4 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!
+5 WRITE ?(80-$LENGTH($PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!
+6 WRITE $$CTR("Listing of the "_BDMTAXN_" taxonomy",80),!,BDM80D,!
+7 QUIT
PRINT ;
+1 SET BDMPG=0
+2 KILL BDMQ
+3 IF BDMTAXT="L"
SET BDMTAXN=$PIECE(^ATXLAB(BDMTAXI,0),U,1)
+4 IF BDMTAXT="T"
SET BDMTAXN=$PIECE(^ATXAX(BDMTAXI,0),U,1)
+5 SET BDM80D="-------------------------------------------------------------------------------"
+6 DO PHDR
+7 IF BDMTAXT'="L"
SET BDMFILE=$PIECE(^ATXAX(BDMTAXI,0),U,15)
+8 IF BDMTAXT="L"
SET BDMFILE=60
P1 KILL ^TMP($JOB,"BDMTAXDSP")
+1 IF BDMTAXT="L"
Begin DoDot:1
+2 SET X=""
FOR
SET X=$ORDER(^ATXLAB(BDMTAXI,21,"B",X))
IF X=""
QUIT
Begin DoDot:2
+3 SET ^TMP($JOB,"BDMTAXDSP",X)=""
End DoDot:2
End DoDot:1
GOTO P11
+4 SET F=$NAME(^TMP($JOB,"BDMTAXDSP"))
+5 IF BDMFILE'=50.67
IF BDMFILE'=9999999.64
IF BDMFILE'=95.3
IF BDMFILE'=60
IF BDMFILE'=9999999.14
DO BLDTAX^ATXAPI(BDMTAXN,F,$ORDER(^ATXAX("B",BDMTAXN,0)))
IF 1
+6 IF '$TEST
SET BDMX=""
FOR
SET BDMX=$ORDER(^ATXAX(BDMTAXI,21,"B",BDMX))
IF BDMX=""
QUIT
SET ^TMP($JOB,"BDMTAXDSP",BDMX)=""
+7 SET BDMFILE=$PIECE(^ATXAX(BDMTAXI,0),U,15)
P11 SET BDMX=""
FOR
SET BDMX=$ORDER(^TMP($JOB,"BDMTAXDSP",BDMX))
IF BDMX=""
QUIT
Begin DoDot:1
+1 SET (BDM1,BDM2,BDMF,BDM3,BDMC2,BDMC3)=""
+2 SET BDMC2=35
SET BDMC3=65
+3 IF BDMFILE=80
SET D=$$ICDDX^ICDEX(BDMX,DT,,"I")
SET BDM1=$PIECE(D,U,2)
SET BDM2=$EXTRACT($PIECE(D,U,4),1,50)
SET BDM3=$PIECE(D,U,20)
SET BDM3=$PIECE(^ICDS(BDM3,0),U,1)
SET BDMC2=15
SET BDMC3=65
+4 IF BDMFILE=80.1
SET D=$$ICDOP^ICDEX(BDMX,DT,,"I")
SET BDM1=$PIECE(D,U,2)
SET BDM2=$EXTRACT($PIECE(D,U,5),1,50)
SET BDM3=$PIECE(D,U,15)
SET BDM3=$PIECE(^ICDS(BDM3,0),U,1)
SET BDMC2=15
SET BDMC3=65
+5 IF BDMFILE=81
SET D=$$CPT^ICPTCOD(BDMX)
SET BDM1=$PIECE(D,U,2)
SET BDM2=$PIECE(D,U,3)
SET BDMC2=15
+6 IF BDMFILE=50.67
SET BDM1=BDMX
SET BDM2=$ORDER(^PSNDF(50.67,"NDC",$$STRIP^XLFSTR(BDM1,"-"),0))
IF BDM2
SET BDM2=$$GET1^DIQ(50.67,BDM2,4)
+7 IF BDMFILE=9999999.64
SET BDM1=$$GET1^DIQ(BDMFILE,BDMX,.01)
+8 IF BDMFILE=9999999.09
SET BDM1=$$GET1^DIQ(BDMFILE,BDMX,.01)
SET BDM2=$$GET1^DIQ(BDMFILE,BDMX,1)
SET BDMC2=50
+9 IF BDMFILE=9999999.14
SET BDM1=BDMX
SET %=$ORDER(^AUTTIMM("C",BDMX,0))
IF %
SET BDM2=$$GET1^DIQ(BDMFILE,%,.01)
SET BDMC2=15
+10 IF BDMFILE=95.3
SET BDM1=BDMX
SET %=$ORDER(^LAB(95.3,"B",$PIECE(BDMX,"-"),0))
IF %
SET BDM2=$$GET1^DIQ(95.3,%,80)
SET BDMC2=15
+11 IF BDM1=""
Begin DoDot:2
+12 SET BDMF=".01"
+13 SET BDM1=$$GET1^DIQ(BDMFILE,BDMX,.01)
End DoDot:2
+14 IF $Y>(IOSL-3)
DO PHDR
IF $DATA(BDMQ)
QUIT
+15 WRITE BDM1,?BDMC2,$EXTRACT(BDM2,1,40),?BDMC3,BDM3,!
End DoDot:1
+16 DO XIT
+17 QUIT
DISPX ;
+1 DO BACK
+2 QUIT
XIT ;
+1 KILL ^TMP($JOB,"BDMTAXDSP")
+2 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
