Routine: DVBHS4

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)

LINE W !,"-------------------------------------------------------------------------------"

 ;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>"

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

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)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHS4   4736     printed  Feb 18, 2025@23:25:29                                                                                                                                                                                                      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

DVBHS4.m