DVBHS4 ; ALB/JLU/PJH;Routine for HINQ screen 4 ; 9/26/11 4:33pm
;;4.0;HINQ;**4,49,62**;03/25/92;Build 17
;
N Y
K DVBX(1)
F LP2=.323,.324,.328,.329,.3291,.3299 S X="DVBDIQ(2,"_DFN_","_LP2_")" K @X
I $D(X(1)) S DVBX(1)=X(1)
S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="DVBDIQ("
S DR=".323;.324:.328;.329;.3291:.3299"
D EN^DIQ1
I $D(DVBX(1)) S X(1)=DVBX(1) K DVBX(1)
;
S DVBSCRN=4 D SCRHD^DVBHUTIL
S DVBJS=44
W ?325,DVBON,"HINQ Data",DVBOFF
W !,?5,"EOD",?17,"RAD",?27,"Bran. Ser.",?44,"Char. Ser.",?69,"Ser. Num."
D LINE
;
;DVB*4*49 - all MS data should be in the BIRLS segment, so if second
;node of all these arrays is populated, kill the first node
I +$G(DVBEOD(2))>0 K DVBEOD(1)
I +$G(DVBRAD(2))>0 K DVBRAD(1)
I $G(DVBBOS(2))]"" K DVBBOS(1)
I $G(DVBCSVC(2))]"" K DVBCSVC(1)
I $G(DVBSN(2))]"" K DVBSN(1)
W ! I $D(DVBEOD(1)),DVBEOD(1)?8N S M=$E(DVBEOD(1),1,2) D MM^DVBHQM11 W M," ",$E(DVBEOD(1),3,4),",",$E(DVBEOD(1),5,8)
I $D(DVBRAD(1)),DVBRAD(1)?8N S M=$E(DVBRAD(1),1,2) D MM^DVBHQM11 W ?14,M," ",$E(DVBRAD(1),3,4),",",$E(DVBRAD(1),5,8)
I $D(DVBBOS(1)) S Y=DVBBOS(1) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
I $D(DVBCSVC(1)) S I=1,Y=DVBCSVC(1) D DISCHG^DVBHQM1 W ?44,Y K Y
I $D(DVBSN(1)) W ?69,DVBSN(1)
W ! I $D(DVBEOD(2)),DVBEOD(2)?7N S Y=DVBEOD(2) X ^DD("DD") W ?1,Y K Y
I $D(DVBRAD(2)),DVBRAD(2)?7N S Y=DVBRAD(2) X ^DD("DD") W ?14,Y K Y
I $D(DVBBOS(2)) S Y=DVBBOS(2) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
I $D(DVBCSVC(2)) S Y=$$DISCH2^DVBHQM1(DVBCSVC(2)) W ?44,Y K Y
I $D(DVBSN(2)) W ?69,DVBSN(2)
W ! I $D(DVBEOD(3)),DVBEOD(3)?7N S Y=DVBEOD(3) X ^DD("DD") W ?1,Y K Y
I $D(DVBRAD(3)),DVBRAD(3)?7N S Y=DVBRAD(3) X ^DD("DD") W ?14,Y K Y
I $D(DVBBOS(3)) S Y=DVBBOS(3) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
I $D(DVBCSVC(3)) S Y=$$DISCH2^DVBHQM1(DVBCSVC(3)) W ?44,Y K Y
I $D(DVBSN(3)) W ?69,DVBSN(3)
W ! I $D(DVBEOD(4)),DVBEOD(4)?7N S Y=DVBEOD(4) X ^DD("DD") W ?1,Y K Y
I $D(DVBRAD(4)),DVBRAD(4)?7N S Y=DVBRAD(4) X ^DD("DD") W ?14,Y K Y
I $D(DVBBOS(4)) S Y=DVBBOS(4) D XBOS^DVBHQM12 S Y=$E(Y,1,16) W ?27,Y
I $D(DVBCSVC(4)) S Y=$$DISCH2^DVBHQM1(DVBCSVC(4)) W ?44,Y K Y
I $D(DVBSN(4)) W ?69,DVBSN(4)
I $D(DVBSCR) K DVBSCR D LINE W ! Q
W !,?34,DVBON,"Patient File",DVBOFF
D LINE,MSE(DFN)
W !,DVBON,"(4)",DVBOFF X DVBLIT1
W ?4,"Per. of Ser.:",?18,$E(DVBDIQ(2,DFN,.323,"E"),1,25)
Q
LINE W !,"-------------------------------------------------------------------------------"
Q
;
;APIs added for MSDS (DVB*4*62)
;------------------------------
;
MSE(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
;
N ARRAY,MORE,SOURCE
;If no data exists in .3216 nodes display old data
S MORE=0,SOURCE=.32 I $O(^DPT(DFN,.3216,"B",0)) S SOURCE=.3216
;
;Collect old data from .32
I SOURCE=.32 D OLD(DFN,.ARRAY)
;Collect last three episodes from .3216 multiple
I SOURCE=.3216 D NEW(DFN,.ARRAY)
;
;Display MSE data
N BOS,COMP,DATA,DISCH,EODATE,IEN,RADATE,SERVN
S CNT=0
F S CNT=$O(ARRAY(CNT)) Q:'CNT D
.S DATA=$G(ARRAY(CNT)) Q:DATA=""
.S DISCH=$P(DATA,U,6) ;Discharge
.S:DISCH]"" DISCH=$P($G(^DIC(25,DISCH,0)),U)
.S BOS=$P(DATA,U,3) ;Branch
.S:BOS]"" BOS=$P($G(^DIC(23,BOS,0)),U)
.S RADATE=$P(DATA,U) ;Entry Date
.S RADATE=$$FMTE^XLFDT(RADATE)
.S EODATE=$P(DATA,U,2) ;Separation Date
.S EODATE=$$FMTE^XLFDT(EODATE)
.S SERVN=$P(DATA,U,5) ;Service Number
.I SOURCE=.32 W !,DVBON,"("_CNT_")",DVBOFF
.I SOURCE=.3216 W !,"<"_CNT_">"
.W $S(CNT=1:" Last",CNT=2:" NTL",1:" NNTL")_" episode"
.;Note that Service Component is not displayed
.W !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
.I CNT=3,MORE W !,?1,"<more episodes>"
Q
;
NEW(DFN,ARRAY) ;Check for new MSE format data
N CNT,SDAT
S CNT=0,SDAT="A"
F S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT D Q:CNT>2
.S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
.S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
.S CNT=CNT+1,ARRAY(CNT)=DATA
.I CNT=3,$O(^DPT(DFN,.3216,"B",SDAT),-1) S MORE=1
Q
;
OLD(DFN,ARRAY) ;Get old format VistA data
N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
;Last service episode (SL)
D EPISODE(1,4,8)
;Next to last service episode (SNL)
Q:$P(DGRP(.32),"^",19)'="Y" D EPISODE(2,9,13)
;Prior episode (SNNL)
I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
Q
;
EPISODE(SUB,P1,P2) ;Get old VistA data and save
S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
;Save in format of new .3216 multiple (no lock flag)
S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHS4 4736 printed Sep 23, 2025@19:35:15 Page 2
DVBHS4 ; ALB/JLU/PJH;Routine for HINQ screen 4 ; 9/26/11 4:33pm
+1 ;;4.0;HINQ;**4,49,62**;03/25/92;Build 17
+2 ;
+3 NEW Y
+4 KILL DVBX(1)
+5 FOR LP2=.323,.324,.328,.329,.3291,.3299
SET X="DVBDIQ(2,"_DFN_","_LP2_")"
KILL @X
+6 IF $DATA(X(1))
SET DVBX(1)=X(1)
+7 SET DIC="^DPT("
SET DA=DFN
SET DIQ(0)="E"
SET DIQ="DVBDIQ("
+8 SET DR=".323;.324:.328;.329;.3291:.3299"
+9 DO EN^DIQ1
+10 IF $DATA(DVBX(1))
SET X(1)=DVBX(1)
KILL DVBX(1)
+11 ;
+12 SET DVBSCRN=4
DO SCRHD^DVBHUTIL
+13 SET DVBJS=44
+14 WRITE ?325,DVBON,"HINQ Data",DVBOFF
+15 WRITE !,?5,"EOD",?17,"RAD",?27,"Bran. Ser.",?44,"Char. Ser.",?69,"Ser. Num."
+16 DO LINE
+17 ;
+18 ;DVB*4*49 - all MS data should be in the BIRLS segment, so if second
+19 ;node of all these arrays is populated, kill the first node
+20 IF +$GET(DVBEOD(2))>0
KILL DVBEOD(1)
+21 IF +$GET(DVBRAD(2))>0
KILL DVBRAD(1)
+22 IF $GET(DVBBOS(2))]""
KILL DVBBOS(1)
+23 IF $GET(DVBCSVC(2))]""
KILL DVBCSVC(1)
+24 IF $GET(DVBSN(2))]""
KILL DVBSN(1)
+25 WRITE !
IF $DATA(DVBEOD(1))
IF DVBEOD(1)?8N
SET M=$EXTRACT(DVBEOD(1),1,2)
DO MM^DVBHQM11
WRITE M," ",$EXTRACT(DVBEOD(1),3,4),",",$EXTRACT(DVBEOD(1),5,8)
+26 IF $DATA(DVBRAD(1))
IF DVBRAD(1)?8N
SET M=$EXTRACT(DVBRAD(1),1,2)
DO MM^DVBHQM11
WRITE ?14,M," ",$EXTRACT(DVBRAD(1),3,4),",",$EXTRACT(DVBRAD(1),5,8)
+27 IF $DATA(DVBBOS(1))
SET Y=DVBBOS(1)
DO XBOS^DVBHQM12
SET Y=$EXTRACT(Y,1,16)
WRITE ?27,Y
+28 IF $DATA(DVBCSVC(1))
SET I=1
SET Y=DVBCSVC(1)
DO DISCHG^DVBHQM1
WRITE ?44,Y
KILL Y
+29 IF $DATA(DVBSN(1))
WRITE ?69,DVBSN(1)
+30 WRITE !
IF $DATA(DVBEOD(2))
IF DVBEOD(2)?7N
SET Y=DVBEOD(2)
XECUTE ^DD("DD")
WRITE ?1,Y
KILL Y
+31 IF $DATA(DVBRAD(2))
IF DVBRAD(2)?7N
SET Y=DVBRAD(2)
XECUTE ^DD("DD")
WRITE ?14,Y
KILL Y
+32 IF $DATA(DVBBOS(2))
SET Y=DVBBOS(2)
DO XBOS^DVBHQM12
SET Y=$EXTRACT(Y,1,16)
WRITE ?27,Y
+33 IF $DATA(DVBCSVC(2))
SET Y=$$DISCH2^DVBHQM1(DVBCSVC(2))
WRITE ?44,Y
KILL Y
+34 IF $DATA(DVBSN(2))
WRITE ?69,DVBSN(2)
+35 WRITE !
IF $DATA(DVBEOD(3))
IF DVBEOD(3)?7N
SET Y=DVBEOD(3)
XECUTE ^DD("DD")
WRITE ?1,Y
KILL Y
+36 IF $DATA(DVBRAD(3))
IF DVBRAD(3)?7N
SET Y=DVBRAD(3)
XECUTE ^DD("DD")
WRITE ?14,Y
KILL Y
+37 IF $DATA(DVBBOS(3))
SET Y=DVBBOS(3)
DO XBOS^DVBHQM12
SET Y=$EXTRACT(Y,1,16)
WRITE ?27,Y
+38 IF $DATA(DVBCSVC(3))
SET Y=$$DISCH2^DVBHQM1(DVBCSVC(3))
WRITE ?44,Y
KILL Y
+39 IF $DATA(DVBSN(3))
WRITE ?69,DVBSN(3)
+40 WRITE !
IF $DATA(DVBEOD(4))
IF DVBEOD(4)?7N
SET Y=DVBEOD(4)
XECUTE ^DD("DD")
WRITE ?1,Y
KILL Y
+41 IF $DATA(DVBRAD(4))
IF DVBRAD(4)?7N
SET Y=DVBRAD(4)
XECUTE ^DD("DD")
WRITE ?14,Y
KILL Y
+42 IF $DATA(DVBBOS(4))
SET Y=DVBBOS(4)
DO XBOS^DVBHQM12
SET Y=$EXTRACT(Y,1,16)
WRITE ?27,Y
+43 IF $DATA(DVBCSVC(4))
SET Y=$$DISCH2^DVBHQM1(DVBCSVC(4))
WRITE ?44,Y
KILL Y
+44 IF $DATA(DVBSN(4))
WRITE ?69,DVBSN(4)
+45 IF $DATA(DVBSCR)
KILL DVBSCR
DO LINE
WRITE !
QUIT
+46 WRITE !,?34,DVBON,"Patient File",DVBOFF
+47 DO LINE
DO MSE(DFN)
+48 WRITE !,DVBON,"(4)",DVBOFF
XECUTE DVBLIT1
+49 WRITE ?4,"Per. of Ser.:",?18,$EXTRACT(DVBDIQ(2,DFN,.323,"E"),1,25)
+50 QUIT
LINE WRITE !,"-------------------------------------------------------------------------------"
+1 QUIT
+2 ;
+3 ;APIs added for MSDS (DVB*4*62)
+4 ;------------------------------
+5 ;
MSE(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
+1 ;
+2 NEW ARRAY,MORE,SOURCE
+3 ;If no data exists in .3216 nodes display old data
+4 SET MORE=0
SET SOURCE=.32
IF $ORDER(^DPT(DFN,.3216,"B",0))
SET SOURCE=.3216
+5 ;
+6 ;Collect old data from .32
+7 IF SOURCE=.32
DO OLD(DFN,.ARRAY)
+8 ;Collect last three episodes from .3216 multiple
+9 IF SOURCE=.3216
DO NEW(DFN,.ARRAY)
+10 ;
+11 ;Display MSE data
+12 NEW BOS,COMP,DATA,DISCH,EODATE,IEN,RADATE,SERVN
+13 SET CNT=0
+14 FOR
SET CNT=$ORDER(ARRAY(CNT))
if 'CNT
QUIT
Begin DoDot:1
+15 SET DATA=$GET(ARRAY(CNT))
if DATA=""
QUIT
+16 ;Discharge
SET DISCH=$PIECE(DATA,U,6)
+17 if DISCH]""
SET DISCH=$PIECE($GET(^DIC(25,DISCH,0)),U)
+18 ;Branch
SET BOS=$PIECE(DATA,U,3)
+19 if BOS]""
SET BOS=$PIECE($GET(^DIC(23,BOS,0)),U)
+20 ;Entry Date
SET RADATE=$PIECE(DATA,U)
+21 SET RADATE=$$FMTE^XLFDT(RADATE)
+22 ;Separation Date
SET EODATE=$PIECE(DATA,U,2)
+23 SET EODATE=$$FMTE^XLFDT(EODATE)
+24 ;Service Number
SET SERVN=$PIECE(DATA,U,5)
+25 IF SOURCE=.32
WRITE !,DVBON,"("_CNT_")",DVBOFF
+26 IF SOURCE=.3216
WRITE !,"<"_CNT_">"
+27 WRITE $SELECT(CNT=1:" Last",CNT=2:" NTL",1:" NNTL")_" episode"
+28 ;Note that Service Component is not displayed
+29 WRITE !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
+30 IF CNT=3
IF MORE
WRITE !,?1,"<more episodes>"
End DoDot:1
+31 QUIT
+32 ;
NEW(DFN,ARRAY) ;Check for new MSE format data
+1 NEW CNT,SDAT
+2 SET CNT=0
SET SDAT="A"
+3 FOR
SET SDAT=$ORDER(^DPT(DFN,.3216,"B",SDAT),-1)
if 'SDAT
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^DPT(DFN,.3216,"B",SDAT,0))
if 'IEN
QUIT
+5 SET DATA=$GET(^DPT(DFN,.3216,IEN,0))
if DATA=""
QUIT
+6 SET CNT=CNT+1
SET ARRAY(CNT)=DATA
+7 IF CNT=3
IF $ORDER(^DPT(DFN,.3216,"B",SDAT),-1)
SET MORE=1
End DoDot:1
if CNT>2
QUIT
+8 QUIT
+9 ;
OLD(DFN,ARRAY) ;Get old format VistA data
+1 NEW DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
+2 SET DGRP(.32)=$GET(^DPT(DFN,.32))
SET DGRP(.3291)=$GET(^DPT(DFN,.3291))
+3 ;Last service episode (SL)
+4 DO EPISODE(1,4,8)
+5 ;Next to last service episode (SNL)
+6 if $PIECE(DGRP(.32),"^",19)'="Y"
QUIT
DO EPISODE(2,9,13)
+7 ;Prior episode (SNNL)
+8 IF $PIECE(DGRP(.32),"^",20)="Y"
DO EPISODE(3,14,18)
+9 QUIT
+10 ;
EPISODE(SUB,P1,P2) ;Get old VistA data and save
+1 SET DGRPX=$PIECE(DGRP(.32),U,P1,P2)
SET DGRPCO=$PIECE(DGRP(.3291),U,SUB)
+2 SET DGRPDI=$PIECE(DGRPX,U)
SET DGRPBR=$PIECE(DGRPX,U,2)
SET DGRPED=$PIECE(DGRPX,U,3)
+3 SET DGRPSD=$PIECE(DGRPX,U,4)
SET DGRPSN=$PIECE(DGRPX,U,5)
+4 ;Save in format of new .3216 multiple (no lock flag)
+5 SET ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U
+6 QUIT
