BGP8XTV1 ; IHS/CMI/LAB - DISPLAY IND LISTS ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;; ;
EP(BGPTAXI,BGPTYPE,BGPFIEN) ;EP - CALLED FROM OPTION
NEW BGPRPTTT,BGPRPTT1,BGPRPTT2
D EN
Q
EOJ ;EP
D EN^XBVK("BGP")
Q
;; ;
EN ;EP -- main entry point for
D TERM^VALM0
D EN^VALM("BGP 18 TAXONOMY VIEW ONE")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ; -- header code
S VALMHDR(1)="Display of the "_$$NAME(BGPTAXI,BGPTYPE)_" taxonomy"
S VALMHDR(2)="* View Taxonomies"
Q
;
NAME(I,T) ;
I T="L" Q $P(^ATXLAB(I,0),U)
I T'="L" Q $P(^ATXAX(I,0),U)
Q ""
INIT ; -- init variables and list array
;
S VALMSG="Select the Appropriate Action Q to Quit"
I BGPTYPE="L" S BGPFILE=60
I BGPTYPE'="L" S BGPFILE=$P(^ATXAX(BGPTAXI,0),U,15)
I BGPTYPE="L" D LAB Q
I BGPTYPE="A"!(BGPTYPE="N") D CANDISP Q
I $P(^ATXAX(BGPTAXI,0),U,13) D CANDISP Q
K BGPITEM S BGPHIGH="",C=0
S BGPX=0 F S BGPX=$O(^ATXAX(BGPTAXI,21,"B",BGPX)) Q:BGPX="" D
.S BGPY=$O(^ATXAX(BGPTAXI,21,"B",BGPX,0)) Q:BGPY'=+BGPY D
..S C=C+1
..S BGPITMI=$P(^ATXAX(BGPTAXI,21,BGPY,0),U)
..I BGPFILE=9999999.05 S BGPITEM(C,0)=C_") "_BGPITMI I 1
..E S BGPITEM(C,0)=C_") "_$$VAL^XBDIQ1($P(^ATXAX(BGPTAXI,0),U,15),BGPITMI,.01)
..S BGPITEM("IDX",C,C)=BGPITMI
.Q
S (VALMCNT,BGPHIGH)=C
Q
CANDISP ;
K BGPITEM S BGPHIGH="",C=0
S BGPX=0 F S BGPX=$O(^ATXAX(BGPTAXI,21,"B",BGPX)) Q:BGPX="" D
.S BGPY=0 F S BGPY=$O(^ATXAX(BGPTAXI,21,"B",BGPX,BGPY)) Q:BGPY="" D
..S C=C+1
..S BGPITEM(C,0)=C_") "_$P(^ATXAX(BGPTAXI,21,BGPY,0),U)_" through "_$P(^ATXAX(BGPTAXI,21,BGPY,0),U,2) I $P(^ATXAX(BGPTAXI,21,BGPY,0),U,3) S $E(BGPITEM(C,0),40)=$P(^ICDS($P(^ATXAX(BGPTAXI,21,BGPY,0),U,3),0),U,1)
..S BGPITEM("IDX",C,C)=BGPX
.Q
S (VALMCNT,BGPHIGH)=C
Q
LAB ;
K BGPITEM S BGPHIGH="",C=0
S BGPX=0 F S BGPX=$O(^ATXLAB(BGPTAXI,21,BGPX)) Q:BGPX'=+BGPX D
.S C=C+1
.S BGPITMI=$P(^ATXLAB(BGPTAXI,21,BGPX,0),U)
.S BGPITEM(C,0)=C_") "_$P($G(^LAB(60,BGPITMI,0)),U)
.S BGPITEM("IDX",C,C)=BGPITMI
.Q
S (VALMCNT,BGPHIGH)=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
BGP8XTV1 ; IHS/CMI/LAB - DISPLAY IND LISTS ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;; ;
EP(BGPTAXI,BGPTYPE,BGPFIEN) ;EP - CALLED FROM OPTION
+1 NEW BGPRPTTT,BGPRPTT1,BGPRPTT2
+2 DO EN
+3 QUIT
EOJ ;EP
+1 DO EN^XBVK("BGP")
+2 QUIT
+3 ;; ;
EN ;EP -- main entry point for
+1 DO TERM^VALM0
+2 DO EN^VALM("BGP 18 TAXONOMY VIEW ONE")
+3 DO CLEAR^VALM1
+4 DO FULL^VALM1
+5 IF $DATA(IOF)
WRITE @IOF
+6 DO EOJ
+7 QUIT
+8 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Display of the "_$$NAME(BGPTAXI,BGPTYPE)_" taxonomy"
+2 SET VALMHDR(2)="* View Taxonomies"
+3 QUIT
+4 ;
NAME(I,T) ;
+1 IF T="L"
QUIT $PIECE(^ATXLAB(I,0),U)
+2 IF T'="L"
QUIT $PIECE(^ATXAX(I,0),U)
+3 QUIT ""
INIT ; -- init variables and list array
+1 ;
+2 SET VALMSG="Select the Appropriate Action Q to Quit"
+3 IF BGPTYPE="L"
SET BGPFILE=60
+4 IF BGPTYPE'="L"
SET BGPFILE=$PIECE(^ATXAX(BGPTAXI,0),U,15)
+5 IF BGPTYPE="L"
DO LAB
QUIT
+6 IF BGPTYPE="A"!(BGPTYPE="N")
DO CANDISP
QUIT
+7 IF $PIECE(^ATXAX(BGPTAXI,0),U,13)
DO CANDISP
QUIT
+8 KILL BGPITEM
SET BGPHIGH=""
SET C=0
+9 SET BGPX=0
FOR
SET BGPX=$ORDER(^ATXAX(BGPTAXI,21,"B",BGPX))
IF BGPX=""
QUIT
Begin DoDot:1
+10 SET BGPY=$ORDER(^ATXAX(BGPTAXI,21,"B",BGPX,0))
IF BGPY'=+BGPY
QUIT
Begin DoDot:2
+11 SET C=C+1
+12 SET BGPITMI=$PIECE(^ATXAX(BGPTAXI,21,BGPY,0),U)
+13 IF BGPFILE=9999999.05
SET BGPITEM(C,0)=C_") "_BGPITMI
IF 1
+14 IF '$TEST
SET BGPITEM(C,0)=C_") "_$$VAL^XBDIQ1($PIECE(^ATXAX(BGPTAXI,0),U,15),BGPITMI,.01)
+15 SET BGPITEM("IDX",C,C)=BGPITMI
End DoDot:2
+16 QUIT
End DoDot:1
+17 SET (VALMCNT,BGPHIGH)=C
+18 QUIT
CANDISP ;
+1 KILL BGPITEM
SET BGPHIGH=""
SET C=0
+2 SET BGPX=0
FOR
SET BGPX=$ORDER(^ATXAX(BGPTAXI,21,"B",BGPX))
IF BGPX=""
QUIT
Begin DoDot:1
+3 SET BGPY=0
FOR
SET BGPY=$ORDER(^ATXAX(BGPTAXI,21,"B",BGPX,BGPY))
IF BGPY=""
QUIT
Begin DoDot:2
+4 SET C=C+1
+5 SET BGPITEM(C,0)=C_") "_$PIECE(^ATXAX(BGPTAXI,21,BGPY,0),U)_" through "_$PIECE(^ATXAX(BGPTAXI,21,BGPY,0),U,2)
IF $PIECE(^ATXAX(BGPTAXI,21,BGPY,0),U,3)
SET $EXTRACT(BGPITEM(C,0),40)=$PIECE(^ICDS($PIECE(^ATXAX(BGPTAXI,21,BGPY,0),U,3),0),U,1)
+6 SET BGPITEM("IDX",C,C)=BGPX
End DoDot:2
+7 QUIT
End DoDot:1
+8 SET (VALMCNT,BGPHIGH)=C
+9 QUIT
LAB ;
+1 KILL BGPITEM
SET BGPHIGH=""
SET C=0
+2 SET BGPX=0
FOR
SET BGPX=$ORDER(^ATXLAB(BGPTAXI,21,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+3 SET C=C+1
+4 SET BGPITMI=$PIECE(^ATXLAB(BGPTAXI,21,BGPX,0),U)
+5 SET BGPITEM(C,0)=C_") "_$PIECE($GET(^LAB(60,BGPITMI,0)),U)
+6 SET BGPITEM("IDX",C,C)=BGPITMI
+7 QUIT
End DoDot:1
+8 SET (VALMCNT,BGPHIGH)=C
+9 QUIT
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
