- DVBHQZ6 ;ISC-ALBANY/JLU/PHH/PJH-print message ; 9/26/11 4:31pm
- ;;4.0;HINQ;**28,49,57,62**;03/25/92 ;Build 17
- 1 W @$S('$D(IOF):"#",IOF="":"#",1:IOF),!!!
- 2 D 2^DVBHUTIL
- 3 W !!!,?5,"Printout by (M)ultiple patients, (R)equestor, (D)ate/time? Multiple//"
- R DVBA:DTIME G:DVBA="^"!('$T) K S:DVBA="" DVBA="M"
- S (DVBMM2,DVBMM)=1 D M:"Mm"[DVBA,R:"Rr"[DVBA,D:"Dd"[DVBA
- I "MRDmrd"'[DVBA W !!,*7,?10,"Answer with an 'M', 'R', 'D', <RET> for 'M', or '^' to quit." G 3
- K K DVBI,R1,DVBLEN,DVBMM2,X,POP,DVBMM1,DVBA,DVBLP,DVB,DVBMM,DVBLP1,DIC,%,DFN,ZTRTN,ZTSAVE,ZTDESC,ZTIO,DVBJIO,POP,Y,ZTSK,DVBDXSC,DVBIXMZ,DVBUSER,R,DVBCS,%DT,DVBTO,DVBFR
- K1 K DVBAL,DVBLP2,DVBIO,DVBLP1,DVBLP1,DVB,DVBMM,DVBJIO I '$D(ZTSK) X ^%ZIS("C")
- Q
- M S DVB="",DIC="^DVB(395.5,",DIC(0)="AEMZQ"
- S DIC("S")="I $D(^(""RS"",0))",DIC("A")="Select patient from ""HINQ Suspense file"":"
- F DVBLP=1:1 D ^DIC Q:Y'>0 S DVB=DVB_+Y_"^"
- K DIC I Y'>0,DVB="" Q
- W ! S ZTRTN="M1^DVBHQZ6",ZTSAVE("DVB")=DVB,ZTSAVE("DVBLP")=DVBLP S:$D(DVBMM2) ZTSAVE("DVBMM2")=DVBMM2 S:$D(DVBMM) ZTSAVE("DVBMM")=DVBMM D LD:'$D(DVBMM1) Q:$D(IO("Q"))!(POP)
- M1 F DVBLP1=1:1:DVBLP-1 S DFN=$P(DVB,U,DVBLP1),DVBJIO=$S(IO'=IO(0):IO,1:IO(0)) I $D(^DVB(395.5,DFN,0)),($D(^("RS"))) D TEM^DVBHIQR D:'$D(DVBERCS) EN^DVBHIQM,WRT1^DVBHQD1:'$D(DVBMM1) W:$D(DVBMM1) "." Q:X="^"
- Q
- ;
- DT S %DT="TAEP",%DT("A")="From:" D ^%DT Q:Y<0 S DVBFR=Y,%DT("A")="To:" D ^%DT Q:Y<0 I DVBFR>Y W !,*7,*7,"TO date cannot be earlier than FROM date." G DT
- S DVBTO=9999999-(Y+.2400),DVBFR=9999999-(DVBFR-.000001) K %DT Q
- ;
- R S DIC(0)="AQME",DIC=200 D ^DIC Q:Y<0 S DVBAL=+Y
- D DT Q:'$D(DVBFR)!('$D(DVBTO))
- S ZTSAVE("DVBMM2")=DVBMM2,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBAL")=DVBAL,ZTSAVE("DVBFR")=DVBFR,ZTSAVE("DVBTO")=DVBTO,ZTRTN="R1^DVBHQZ6" D LD Q:$D(IO("Q"))!(POP)
- R1 S X="" F DVBLP=DVBTO:0:9999999 S DVBLP=$O(^DVB(395.5,"C",DVBLP)) Q:DVBLP>DVBFR!(X="^")!('DVBLP) F DFN=0:0 S DFN=$O(^DVB(395.5,"C",DVBLP,DFN)) Q:'DFN!(X="^") I $D(^DVB(395.5,"D",DVBAL,DFN,DVBAL)),$D(^DVB(395.5,DFN,0)),$D(^("RS")) D R3
- Q
- ;
- R3 S DVBJIO=$S(IO'=IO(0):IO,1:IO(0)) D TEM^DVBHIQR D:'$D(DVBERCS) EN^DVBHIQM,WRT1^DVBHQD1 Q
- ;
- D D DT Q:'$D(DVBFR)!('$D(DVBTO))
- S ZTSAVE("DVBMM2")=DVBMM2,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBFR")=DVBFR,ZTSAVE("DVBTO")=DVBTO,ZTRTN="D1^DVBHQZ6" D LD Q:$D(IO("Q"))!(POP)
- D1 S X="" F DVBLP=DVBTO:0:9999999 S DVBLP=$O(^DVB(395.5,"C",DVBLP)) Q:DVBLP>DVBFR!(X="^")!('DVBLP) F DFN=0:0 S DFN=$O(^DVB(395.5,"C",DVBLP,DFN)) Q:'DFN!(X="^") I $D(^DVB(395.5,DFN,0)),$D(^("RS")) D R3
- Q
- ;
- EM W !!,"Do you wish to create a mail message, to be sent to the requestors" S %=2 D YN^DICN I %=0 W *7,!,"'YES' to create a mail message 'NO' will not" G EM
- I %=1 S DVBMM1=1,POP=0 D M W:$D(DVBLP1) !,"Mail Sent."
- D K Q
- ;
- LD S %IS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) S ZTDESC="This is the HINQ Print/Mail option.",ZTIO=ION D ^%ZTLOAD X ^%ZIS("C")
- Q
- ;
- S1 ;
- I $D(DVBDX) D LABELS^DVBHS3
- F JU=0:0 S JU=$O(DVBDX(JU)) Q:'JU I +DVBDX(JU),DVBDX(JU)'["-" D S2
- Q
- S2 I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE^DVBHS3
- I $G(QUIT)=1 Q
- W !,$S($P(DVBDX(JU),U,2)="":$P(DVBDX(JU),U),$D(^DIC(31,$P(DVBDX(JU),U,2),0)):$E($P(^(0),U),1,40),1:"")
- W ?42,$S($P(DVBDX(JU),U,3)="X0":100,1:+$P(DVBDX(JU),U,3))
- W ?50,$P($G(DVBDX(JU)),U,4)
- ;DVB*4*54 - format date fields
- N DVBF,DVBFF
- F DVBF=5,6 S DVBFF=$P($G(DVBDX(JU)),U,DVBF) D
- . I $G(DVBFF)?8N D
- . . S M=$E(DVBFF,1,2)
- . . D MM^DVBHQM11
- . . S DVBF(DVBF)=M_" "_$S($E(DVBFF,3,4)]"":$E(DVBFF,3,4),1:" ")_","_$E(DVBFF,5,8)
- W ?55,$G(DVBF(5)),?68,$G(DVBF(6))
- K QUIT
- Q
- ;
- QB S %=2 W !!,"Would you like a HINQ message printed out " D YN^DICN I %<0!(%=2) Q
- I '% W !!,"A YES will result in a HINQ printout queued to the device you select." G QB
- W !,"I will queue all messages!"
- K IOP S %IS="NMQ",%IS("B")="" D ^%ZIS K %IS I POP W !,"No printout queued!" G EX
- S IOP=ION_";"_IOST_$S($D(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
- I IO=IO(0) W !,"Can not queue to your HOME device." G QB
- I IO'=IO(0),'$D(IO("Q")) W !,"I am QUEUEING this report to run now." S IO("Q")=1,ZTDTH=$H
- S DVBMM2=1,ZTRTN="M1^DVBHQZ6",ZTIO=IOP,ZTSAVE("DVB")=DVB,ZTSAVE("DVBLP")=DVBLP,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBMM2")=DVBMM2,ZTDESC="This is the HINQ report." K IO("Q") D ^%ZTLOAD
- EX S IOP="HOME" D ^%ZIS K DVB,DVBLP,DVBMM,DVBMM2,ZTRTN,ZTIO,ZTSAVE,ZTDESC,IOP Q
- ;
- ;APIs added for MSDS (DVB*4*62)
- ;------------------------------
- ;
- DISP(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
- ;
- N ARRAY,MORE
- ;If no data exists in .3216 nodes display old data
- I '$O(^DPT(DFN,.3216,"B",0)) D OLD(DFN,.ARRAY)
- ;Otherwise use .3216 multiple
- E 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 CNT=1 W !,?1,"Last episode"
- .I CNT=2 W !,?1,"NTL episode"
- .I CNT=3 W !,?1,"NNTL episode"
- .;Note that Service Component is not displayed
- .W !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
- .I CNT=3,$G(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[HDVBHQZ6 6444 printed Feb 18, 2025@23:25:25 Page 2
- DVBHQZ6 ;ISC-ALBANY/JLU/PHH/PJH-print message ; 9/26/11 4:31pm
- +1 ;;4.0;HINQ;**28,49,57,62**;03/25/92 ;Build 17
- 1 WRITE @$SELECT('$DATA(IOF):"#",IOF="":"#",1:IOF),!!!
- 2 DO 2^DVBHUTIL
- 3 WRITE !!!,?5,"Printout by (M)ultiple patients, (R)equestor, (D)ate/time? Multiple//"
- +1 READ DVBA:DTIME
- if DVBA="^"!('$TEST)
- GOTO K
- if DVBA=""
- SET DVBA="M"
- +2 SET (DVBMM2,DVBMM)=1
- if "Mm"[DVBA
- DO M
- if "Rr"[DVBA
- DO R
- if "Dd"[DVBA
- DO D
- +3 IF "MRDmrd"'[DVBA
- WRITE !!,*7,?10,"Answer with an 'M', 'R', 'D', <RET> for 'M', or '^' to quit."
- GOTO 3
- K KILL DVBI,R1,DVBLEN,DVBMM2,X,POP,DVBMM1,DVBA,DVBLP,DVB,DVBMM,DVBLP1,DIC,%,DFN,ZTRTN,ZTSAVE,ZTDESC,ZTIO,DVBJIO,POP,Y,ZTSK,DVBDXSC,DVBIXMZ,DVBUSER,R,DVBCS,%DT,DVBTO,DVBFR
- K1 KILL DVBAL,DVBLP2,DVBIO,DVBLP1,DVBLP1,DVB,DVBMM,DVBJIO
- IF '$DATA(ZTSK)
- XECUTE ^%ZIS("C")
- +1 QUIT
- M SET DVB=""
- SET DIC="^DVB(395.5,"
- SET DIC(0)="AEMZQ"
- +1 SET DIC("S")="I $D(^(""RS"",0))"
- SET DIC("A")="Select patient from ""HINQ Suspense file"":"
- +2 FOR DVBLP=1:1
- DO ^DIC
- if Y'>0
- QUIT
- SET DVB=DVB_+Y_"^"
- +3 KILL DIC
- IF Y'>0
- IF DVB=""
- QUIT
- +4 WRITE !
- SET ZTRTN="M1^DVBHQZ6"
- SET ZTSAVE("DVB")=DVB
- SET ZTSAVE("DVBLP")=DVBLP
- if $DATA(DVBMM2)
- SET ZTSAVE("DVBMM2")=DVBMM2
- if $DATA(DVBMM)
- SET ZTSAVE("DVBMM")=DVBMM
- if '$DATA(DVBMM1)
- DO LD
- if $DATA(IO("Q"))!(POP)
- QUIT
- M1 FOR DVBLP1=1:1:DVBLP-1
- SET DFN=$PIECE(DVB,U,DVBLP1)
- SET DVBJIO=$SELECT(IO'=IO(0):IO,1:IO(0))
- IF $DATA(^DVB(395.5,DFN,0))
- IF ($DATA(^("RS")))
- DO TEM^DVBHIQR
- if '$DATA(DVBERCS)
- DO EN^DVBHIQM
- if '$DATA(DVBMM1)
- DO WRT1^DVBHQD1
- if $DATA(DVBMM1)
- WRITE "."
- if X="^"
- QUIT
- +1 QUIT
- +2 ;
- DT SET %DT="TAEP"
- SET %DT("A")="From:"
- DO ^%DT
- if Y<0
- QUIT
- SET DVBFR=Y
- SET %DT("A")="To:"
- DO ^%DT
- if Y<0
- QUIT
- IF DVBFR>Y
- WRITE !,*7,*7,"TO date cannot be earlier than FROM date."
- GOTO DT
- +1 SET DVBTO=9999999-(Y+.2400)
- SET DVBFR=9999999-(DVBFR-.000001)
- KILL %DT
- QUIT
- +2 ;
- R SET DIC(0)="AQME"
- SET DIC=200
- DO ^DIC
- if Y<0
- QUIT
- SET DVBAL=+Y
- +1 DO DT
- if '$DATA(DVBFR)!('$DATA(DVBTO))
- QUIT
- +2 SET ZTSAVE("DVBMM2")=DVBMM2
- SET ZTSAVE("DVBMM")=DVBMM
- SET ZTSAVE("DVBAL")=DVBAL
- SET ZTSAVE("DVBFR")=DVBFR
- SET ZTSAVE("DVBTO")=DVBTO
- SET ZTRTN="R1^DVBHQZ6"
- DO LD
- if $DATA(IO("Q"))!(POP)
- QUIT
- R1 SET X=""
- FOR DVBLP=DVBTO:0:9999999
- SET DVBLP=$ORDER(^DVB(395.5,"C",DVBLP))
- if DVBLP>DVBFR!(X="^")!('DVBLP)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DVB(395.5,"C",DVBLP,DFN))
- if 'DFN!(X="^")
- QUIT
- IF $DATA(^DVB(395.5,"D",DVBAL,DFN,DVBAL))
- IF $DATA(^DVB(395.5,DFN,0))
- IF $DATA(^("RS"))
- DO R3
- +1 QUIT
- +2 ;
- R3 SET DVBJIO=$SELECT(IO'=IO(0):IO,1:IO(0))
- DO TEM^DVBHIQR
- if '$DATA(DVBERCS)
- DO EN^DVBHIQM
- DO WRT1^DVBHQD1
- QUIT
- +1 ;
- D DO DT
- if '$DATA(DVBFR)!('$DATA(DVBTO))
- QUIT
- +1 SET ZTSAVE("DVBMM2")=DVBMM2
- SET ZTSAVE("DVBMM")=DVBMM
- SET ZTSAVE("DVBFR")=DVBFR
- SET ZTSAVE("DVBTO")=DVBTO
- SET ZTRTN="D1^DVBHQZ6"
- DO LD
- if $DATA(IO("Q"))!(POP)
- QUIT
- D1 SET X=""
- FOR DVBLP=DVBTO:0:9999999
- SET DVBLP=$ORDER(^DVB(395.5,"C",DVBLP))
- if DVBLP>DVBFR!(X="^")!('DVBLP)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DVB(395.5,"C",DVBLP,DFN))
- if 'DFN!(X="^")
- QUIT
- IF $DATA(^DVB(395.5,DFN,0))
- IF $DATA(^("RS"))
- DO R3
- +1 QUIT
- +2 ;
- EM WRITE !!,"Do you wish to create a mail message, to be sent to the requestors"
- SET %=2
- DO YN^DICN
- IF %=0
- WRITE *7,!,"'YES' to create a mail message 'NO' will not"
- GOTO EM
- +1 IF %=1
- SET DVBMM1=1
- SET POP=0
- DO M
- if $DATA(DVBLP1)
- WRITE !,"Mail Sent."
- +2 DO K
- QUIT
- +3 ;
- LD SET %IS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- SET ZTDESC="This is the HINQ Print/Mail option."
- SET ZTIO=ION
- DO ^%ZTLOAD
- XECUTE ^%ZIS("C")
- +1 QUIT
- +2 ;
- S1 ;
- +1 IF $DATA(DVBDX)
- DO LABELS^DVBHS3
- +2 FOR JU=0:0
- SET JU=$ORDER(DVBDX(JU))
- if 'JU
- QUIT
- IF +DVBDX(JU)
- IF DVBDX(JU)'["-"
- DO S2
- +3 QUIT
- S2 IF ($Y+5)>IOSL
- IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE^DVBHS3
- +1 IF $GET(QUIT)=1
- QUIT
- +2 WRITE !,$SELECT($PIECE(DVBDX(JU),U,2)="":$PIECE(DVBDX(JU),U),$DATA(^DIC(31,$PIECE(DVBDX(JU),U,2),0)):$EXTRACT($PIECE(^(0),U),1,40),1:"")
- +3 WRITE ?42,$SELECT($PIECE(DVBDX(JU),U,3)="X0":100,1:+$PIECE(DVBDX(JU),U,3))
- +4 WRITE ?50,$PIECE($GET(DVBDX(JU)),U,4)
- +5 ;DVB*4*54 - format date fields
- +6 NEW DVBF,DVBFF
- +7 FOR DVBF=5,6
- SET DVBFF=$PIECE($GET(DVBDX(JU)),U,DVBF)
- Begin DoDot:1
- +8 IF $GET(DVBFF)?8N
- Begin DoDot:2
- +9 SET M=$EXTRACT(DVBFF,1,2)
- +10 DO MM^DVBHQM11
- +11 SET DVBF(DVBF)=M_" "_$SELECT($EXTRACT(DVBFF,3,4)]"":$EXTRACT(DVBFF,3,4),1:" ")_","_$EXTRACT(DVBFF,5,8)
- End DoDot:2
- End DoDot:1
- +12 WRITE ?55,$GET(DVBF(5)),?68,$GET(DVBF(6))
- +13 KILL QUIT
- +14 QUIT
- +15 ;
- QB SET %=2
- WRITE !!,"Would you like a HINQ message printed out "
- DO YN^DICN
- IF %<0!(%=2)
- QUIT
- +1 IF '%
- WRITE !!,"A YES will result in a HINQ printout queued to the device you select."
- GOTO QB
- +2 WRITE !,"I will queue all messages!"
- +3 KILL IOP
- SET %IS="NMQ"
- SET %IS("B")=""
- DO ^%ZIS
- KILL %IS
- IF POP
- WRITE !,"No printout queued!"
- GOTO EX
- +4 SET IOP=ION_";"_IOST_$SELECT($DATA(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
- +5 IF IO=IO(0)
- WRITE !,"Can not queue to your HOME device."
- GOTO QB
- +6 IF IO'=IO(0)
- IF '$DATA(IO("Q"))
- WRITE !,"I am QUEUEING this report to run now."
- SET IO("Q")=1
- SET ZTDTH=$HOROLOG
- +7 SET DVBMM2=1
- SET ZTRTN="M1^DVBHQZ6"
- SET ZTIO=IOP
- SET ZTSAVE("DVB")=DVB
- SET ZTSAVE("DVBLP")=DVBLP
- SET ZTSAVE("DVBMM")=DVBMM
- SET ZTSAVE("DVBMM2")=DVBMM2
- SET ZTDESC="This is the HINQ report."
- KILL IO("Q")
- DO ^%ZTLOAD
- EX SET IOP="HOME"
- DO ^%ZIS
- KILL DVB,DVBLP,DVBMM,DVBMM2,ZTRTN,ZTIO,ZTSAVE,ZTDESC,IOP
- QUIT
- +1 ;
- +2 ;APIs added for MSDS (DVB*4*62)
- +3 ;------------------------------
- +4 ;
- DISP(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
- +1 ;
- +2 NEW ARRAY,MORE
- +3 ;If no data exists in .3216 nodes display old data
- +4 IF '$ORDER(^DPT(DFN,.3216,"B",0))
- DO OLD(DFN,.ARRAY)
- +5 ;Otherwise use .3216 multiple
- +6 IF '$TEST
- DO NEW(DFN,.ARRAY)
- +7 ;
- +8 ;Display MSE data
- +9 NEW BOS,COMP,DATA,DISCH,EODATE,IEN,RADATE,SERVN
- +10 SET CNT=0
- +11 FOR
- SET CNT=$ORDER(ARRAY(CNT))
- if 'CNT
- QUIT
- Begin DoDot:1
- +12 SET DATA=$GET(ARRAY(CNT))
- if DATA=""
- QUIT
- +13 ;Discharge
- SET DISCH=$PIECE(DATA,U,6)
- +14 if DISCH]""
- SET DISCH=$PIECE($GET(^DIC(25,DISCH,0)),U)
- +15 ;Branch
- SET BOS=$PIECE(DATA,U,3)
- +16 if BOS]""
- SET BOS=$PIECE($GET(^DIC(23,BOS,0)),U)
- +17 ;Entry Date
- SET RADATE=$PIECE(DATA,U)
- +18 SET RADATE=$$FMTE^XLFDT(RADATE)
- +19 ;Separation Date
- SET EODATE=$PIECE(DATA,U,2)
- +20 SET EODATE=$$FMTE^XLFDT(EODATE)
- +21 ;Service Number
- SET SERVN=$PIECE(DATA,U,5)
- +22 IF CNT=1
- WRITE !,?1,"Last episode"
- +23 IF CNT=2
- WRITE !,?1,"NTL episode"
- +24 IF CNT=3
- WRITE !,?1,"NNTL episode"
- +25 ;Note that Service Component is not displayed
- +26 WRITE !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
- +27 IF CNT=3
- IF $GET(MORE)
- WRITE !,?1,"<more episodes>"
- End DoDot:1
- +28 QUIT
- +29 ;
- 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