IVMPREC7 ;ALB/SEK,RTK - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ; 31 May 94
;;2.0;INCOME VERIFICATION MATCH;**1,17,44,34,77**;21-OCT-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine will process (validate) batch ORU Means Test(event type
; Z06) HL7 messages received from the IVM center. Format of batch:
; BHS
; {MSH
; PID
; ZIC
; ZIR
; {ZDP
; ZIC
; ZIR
; }
; ZMT
; }
; BTS
;
EN ; entry point to validate Means Test messages
;
F IVMDA=1:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D Q:'IVMDA
.K HLERR
EN1 .S HLMID=$P(IVMSEG,HLFS,10) ; message control id from MSH
.S IVMFLGC=0
.D GET I IVMSEG1'="PID" D Q
..S HLERR="Missing PID segment" D ACK^IVMPREC
.S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
.I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
..S HLERR="Invalid DFN" D ACK^IVMPREC
.I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" D ACK^IVMPREC Q
.S IVMDAP=IVMDA ; save IVMDA for veteran PID segment
.;
.; check for veteran's ZIC and ZIR segments
.D GET I IVMSEG1'="ZIC" D Q
..S HLERR="Missing veteran's ZIC segment" D ACK^IVMPREC
.S IVMDGLY=$P(IVMSEG,"^",3) ; income year
.D GET I IVMSEG1'="ZIR" D Q
..S HLERR="Missing veteran's ZIR segment" D ACK^IVMPREC
.;
.; check for spouse's ZDP, ZIC, ZIR segments
.D GET I IVMSEG1'="ZDP" D Q
..S HLERR="Missing spouse's ZDP segment" D ACK^IVMPREC
.S IVMDAS=IVMDA ; save IVMDA for spouse ZDP segment
.D GET I IVMSEG1'="ZIC" D Q
..S HLERR="Missing spouse's ZIC segment" D ACK^IVMPREC
.D GET I IVMSEG1'="ZIR" D Q
..S HLERR="Missing spouse's ZIR segment" D ACK^IVMPREC
.;
.; check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
.K IVMERR
.S IVMFLG7=0
.F D Q:$D(IVMERR)!(IVMSEG1="ZMT")
..D GET I IVMSEG1'="ZDP"&(IVMSEG1'="ZMT") D Q
...S HLERR="Missing child's ZDP segment or ZMT segment",IVMERR="" D ACK^IVMPREC
..I IVMSEG1="ZMT" D Q
...S:$P(IVMSEG,"^",4)=HLQ IVMFLG7=1 ; delete MT if status is HLQ
...S IVMDAZ=IVMDA ; ZMT segment ivmda
..I $P(IVMSEG,"^",2)']""!($P(IVMSEG,"^",3)']"")!($P(IVMSEG,"^",4)']"") D Q
... S HLERR="Missing child data from ZDP segment",IVMERR="" D ACK^IVMPREC
..D GET I IVMSEG1'="ZIC" D Q
...S HLERR="Missing child's ZIC segment",IVMERR="" D ACK^IVMPREC
..D GET I IVMSEG1'="ZIR" D Q
...S HLERR="Missing child's ZIR segment",IVMERR="" D ACK^IVMPREC
..S IVMFLGC=IVMFLGC+1 ; # of children
.;
.Q:$D(IVMERR)&(IVMSEG1'="MSH")
.G EN1:IVMSEG1="MSH"
.;
.; get primary means test
.; ivmmtdt - means test date
.; dgly - income year
.; if Means Test not in DHCP don't upload IVM Means Test
.S IVMMTDT=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3)) ; means test date from ZMT segment
.S DGLY=$$LYR^DGMTSCU1(IVMMTDT)
.S IVMMTIEN=+$$LST^DGMTU(DFN,IVMMTDT) ; primary means test IEN
.;
.I IVMFLG7 D ^IVMUM7 Q ; delete means test
.;
.S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0)) ; dgmtp is event driver variable
.I $P(IVMMT31,"^")'=IVMMTDT D Q
..S Y=IVMMTDT X ^DD("DD")
..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
..D ERRBULL,MAIL^IVMUFNC()
..S HLERR="Means test not in DHCP" D ACK^IVMPREC
..Q
.I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test sent for "_Y D ACK^IVMPREC Q
.;
.; do not upload IVM means test if primary means test status is
.; 3-no longer required
.; or if hardship case
.S IVMSTAT=$P(IVMMT31,"^",3)
.I IVMSTAT=3 S HLERR="NOT UPLOADED no longer required" D ACK^IVMPREC Q
.I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK^IVMPREC Q
.D ^IVMUM1 ; upload means test
.I $D(HLERR) D ACK^IVMPREC
.;
.; cleanup
.K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB
.Q
Q
;
GET ; get HL7 segment from ^HL
S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
S IVMSEG1=$E(IVMSEG,1,3)
Q
;
ERRBULL ; build mail message for transmission to IVM mail group notifying site
; of upload error.
S IVMPAT=$$PT^IVMUFNC4(DFN)
S XMSUB="IVM - MEANS TEST UPLOAD"
S IVMTEXT(1)="The following error occured when an Income Verification Match"
S IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
S IVMTEXT(3)=" "
S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
S IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
Q
ORF ;entry point for Means Test Signature Z06 msgs.
I $G(HLFS)="" S HLFS="^"
I $G(HLECH)="" S HLECH="~"
F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D Q:'IVMDA
.K HLERR
.S HLMID=$P(IVMSEG,HLFS,10) ; message control id from MSH
.S IVMFLGC=0
.D GET I IVMSEG1'="PID" D Q
..S HLERR="Missing PID segment" D ACK^IVMPREC
.S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
.I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
..S HLERR="Invalid DFN" D ACK^IVMPREC
.I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVMSSN with DHCP SSN" D ACK^IVMPREC Q
.S IVMDAP=IVMDA ; save IVMDA for veteran PID segment
.D GET I IVMSEG1'="ZMT" D Q
..S HLERR="Missing ZMT segment" D ACK^IVMPREC
.; IVMMTDT - means test date
.; DGLY - income year
.; if Means Test not in DHCP don't upload IVM Means Test
.S IVMMTDT=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3)) ; means test date from ZMT segment
.S DGLY=$$LYR^DGMTSCU1(IVMMTDT)
.; get means test to be updated
.N UPMTS
.S MTDATE=-IVMMTDT,IVMMTIEN="",MTFND=0
.F S IVMMTIEN=$O(^DGMT(408.31,"AID",1,DFN,MTDATE,IVMMTIEN),-1) Q:MTFND!(IVMMTIEN="") D
..I $$Z06MT^EASPTRN1(IVMMTIEN) Q ;EDB Z06 - Don't use this one
..; match site completing in case multiple tests for same date
..I $P(IVMSEG,HLFS,23)=$P(^DGMT(408.31,IVMMTIEN,2),HLFS,5) S UPMTS=IVMMTIEN,MTFND=1 Q
.S (IVMMT31,DGMTP)=$G(^DGMT(408.31,UPMTS,0)) ; DGMTP is event driver variable
.I $P(IVMMT31,"^")'=IVMMTDT D Q
..S Y=IVMMTDT X ^DD("DD")
..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
..D ERRBULL,MAIL^IVMUFNC()
..S HLERR="Means test not in DHCP" D ACK^IVMPREC
..Q
.I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test sent for "_Y D ACK^IVMPREC Q
.; do not upload IVM means test if primary means test status is
.; 3-no longer required
.; or if hardship case
.S IVMSTAT=$P(IVMMT31,"^",3)
.I IVMSTAT=3 S HLERR="NOT UPLOADED no longer required" D ACK^IVMPREC Q
.I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK^IVMPREC Q
.;get MT signature and date/time edited info, update means test
.N DATA
.S DATA(.29)=$P(IVMSEG,HLFS,28),DATA(2.02)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,26)) I $D(DATA(.29)) D
..I $$UPD^DGENDBS(408.31,UPMTS,.DATA)
.I '$D(HLERR) D ACK^IVMPREC
.;
.; cleanup
.K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,FMDATE,MTDATE
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPREC7 7090 printed Apr 09, 2024@21:03:08 Page 2
IVMPREC7 ;ALB/SEK,RTK - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ; 31 May 94
+1 ;;2.0;INCOME VERIFICATION MATCH;**1,17,44,34,77**;21-OCT-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine will process (validate) batch ORU Means Test(event type
+5 ; Z06) HL7 messages received from the IVM center. Format of batch:
+6 ; BHS
+7 ; {MSH
+8 ; PID
+9 ; ZIC
+10 ; ZIR
+11 ; {ZDP
+12 ; ZIC
+13 ; ZIR
+14 ; }
+15 ; ZMT
+16 ; }
+17 ; BTS
+18 ;
EN ; entry point to validate Means Test messages
+1 ;
+2 FOR IVMDA=1:0
SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
if 'IVMDA
QUIT
SET IVMSEG=$GET(^(IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)="MSH"
Begin DoDot:1
+3 KILL HLERR
EN1 ; message control id from MSH
SET HLMID=$PIECE(IVMSEG,HLFS,10)
+1 SET IVMFLGC=0
+2 DO GET
IF IVMSEG1'="PID"
Begin DoDot:2
+3 SET HLERR="Missing PID segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+4 SET DFN=$PIECE($PIECE(IVMSEG,HLFS,4),$EXTRACT(HLECH))
+5 IF ('DFN!(DFN'=+DFN)!('$DATA(^DPT(+DFN,0))))
Begin DoDot:2
+6 SET HLERR="Invalid DFN"
DO ACK^IVMPREC
End DoDot:2
QUIT
+7 IF $PIECE(IVMSEG,HLFS,20)'=$PIECE(^DPT(DFN,0),"^",9)
SET HLERR="Couldn't match IVM SSN with DHCP SSN"
DO ACK^IVMPREC
QUIT
+8 ; save IVMDA for veteran PID segment
SET IVMDAP=IVMDA
+9 ;
+10 ; check for veteran's ZIC and ZIR segments
+11 DO GET
IF IVMSEG1'="ZIC"
Begin DoDot:2
+12 SET HLERR="Missing veteran's ZIC segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+13 ; income year
SET IVMDGLY=$PIECE(IVMSEG,"^",3)
+14 DO GET
IF IVMSEG1'="ZIR"
Begin DoDot:2
+15 SET HLERR="Missing veteran's ZIR segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+16 ;
+17 ; check for spouse's ZDP, ZIC, ZIR segments
+18 DO GET
IF IVMSEG1'="ZDP"
Begin DoDot:2
+19 SET HLERR="Missing spouse's ZDP segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+20 ; save IVMDA for spouse ZDP segment
SET IVMDAS=IVMDA
+21 DO GET
IF IVMSEG1'="ZIC"
Begin DoDot:2
+22 SET HLERR="Missing spouse's ZIC segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+23 DO GET
IF IVMSEG1'="ZIR"
Begin DoDot:2
+24 SET HLERR="Missing spouse's ZIR segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+25 ;
+26 ; check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
+27 KILL IVMERR
+28 SET IVMFLG7=0
+29 FOR
Begin DoDot:2
+30 DO GET
IF IVMSEG1'="ZDP"&(IVMSEG1'="ZMT")
Begin DoDot:3
+31 SET HLERR="Missing child's ZDP segment or ZMT segment"
SET IVMERR=""
DO ACK^IVMPREC
End DoDot:3
QUIT
+32 IF IVMSEG1="ZMT"
Begin DoDot:3
+33 ; delete MT if status is HLQ
if $PIECE(IVMSEG,"^",4)=HLQ
SET IVMFLG7=1
+34 ; ZMT segment ivmda
SET IVMDAZ=IVMDA
End DoDot:3
QUIT
+35 IF $PIECE(IVMSEG,"^",2)']""!($PIECE(IVMSEG,"^",3)']"")!($PIECE(IVMSEG,"^",4)']"")
Begin DoDot:3
+36 SET HLERR="Missing child data from ZDP segment"
SET IVMERR=""
DO ACK^IVMPREC
End DoDot:3
QUIT
+37 DO GET
IF IVMSEG1'="ZIC"
Begin DoDot:3
+38 SET HLERR="Missing child's ZIC segment"
SET IVMERR=""
DO ACK^IVMPREC
End DoDot:3
QUIT
+39 DO GET
IF IVMSEG1'="ZIR"
Begin DoDot:3
+40 SET HLERR="Missing child's ZIR segment"
SET IVMERR=""
DO ACK^IVMPREC
End DoDot:3
QUIT
+41 ; # of children
SET IVMFLGC=IVMFLGC+1
End DoDot:2
if $DATA(IVMERR)!(IVMSEG1="ZMT")
QUIT
+42 ;
+43 if $DATA(IVMERR)&(IVMSEG1'="MSH")
QUIT
+44 if IVMSEG1="MSH"
GOTO EN1
+45 ;
+46 ; get primary means test
+47 ; ivmmtdt - means test date
+48 ; dgly - income year
+49 ; if Means Test not in DHCP don't upload IVM Means Test
+50 ; means test date from ZMT segment
SET IVMMTDT=$$FMDATE^HLFNC($PIECE(IVMSEG,HLFS,3))
+51 SET DGLY=$$LYR^DGMTSCU1(IVMMTDT)
+52 ; primary means test IEN
SET IVMMTIEN=+$$LST^DGMTU(DFN,IVMMTDT)
+53 ;
+54 ; delete means test
IF IVMFLG7
DO ^IVMUM7
QUIT
+55 ;
+56 ; dgmtp is event driver variable
SET (IVMMT31,DGMTP)=$GET(^DGMT(408.31,IVMMTIEN,0))
+57 IF $PIECE(IVMMT31,"^")'=IVMMTDT
Begin DoDot:2
+58 SET Y=IVMMTDT
XECUTE ^DD("DD")
+59 SET IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
+60 DO ERRBULL
DO MAIL^IVMUFNC()
+61 SET HLERR="Means test not in DHCP"
DO ACK^IVMPREC
+62 QUIT
End DoDot:2
QUIT
+63 IF $PIECE(IVMMT31,"^",23)=2
SET Y=IVMMTDT
XECUTE ^DD("DD")
SET HLERR="2nd means test sent for "_Y
DO ACK^IVMPREC
QUIT
+64 ;
+65 ; do not upload IVM means test if primary means test status is
+66 ; 3-no longer required
+67 ; or if hardship case
+68 SET IVMSTAT=$PIECE(IVMMT31,"^",3)
+69 IF IVMSTAT=3
SET HLERR="NOT UPLOADED no longer required"
DO ACK^IVMPREC
QUIT
+70 IF $PIECE(IVMMT31,"^",20)=1
SET HLERR="NOT UPLOADED hardship case"
DO ACK^IVMPREC
QUIT
+71 ; upload means test
DO ^IVMUM1
+72 IF $DATA(HLERR)
DO ACK^IVMPREC
+73 ;
+74 ; cleanup
+75 KILL DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB
+76 QUIT
End DoDot:1
if 'IVMDA
QUIT
+77 QUIT
+78 ;
GET ; get HL7 segment from ^HL
+1 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,+IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
+2 SET IVMSEG1=$EXTRACT(IVMSEG,1,3)
+3 QUIT
+4 ;
ERRBULL ; build mail message for transmission to IVM mail group notifying site
+1 ; of upload error.
+2 SET IVMPAT=$$PT^IVMUFNC4(DFN)
+3 SET XMSUB="IVM - MEANS TEST UPLOAD"
+4 SET IVMTEXT(1)="The following error occured when an Income Verification Match"
+5 SET IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
+6 SET IVMTEXT(3)=" "
+7 SET IVMTEXT(4)=" NAME: "_$PIECE(IVMPAT,"^")
+8 SET IVMTEXT(5)=" ID: "_$PIECE(IVMPAT,"^",2)
+9 SET IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
+10 QUIT
ORF ;entry point for Means Test Signature Z06 msgs.
+1 IF $GET(HLFS)=""
SET HLFS="^"
+2 IF $GET(HLECH)=""
SET HLECH="~"
+3 FOR IVMDA=0:0
SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
if 'IVMDA
QUIT
SET IVMSEG=$GET(^(IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)="MSH"
Begin DoDot:1
+4 KILL HLERR
+5 ; message control id from MSH
SET HLMID=$PIECE(IVMSEG,HLFS,10)
+6 SET IVMFLGC=0
+7 DO GET
IF IVMSEG1'="PID"
Begin DoDot:2
+8 SET HLERR="Missing PID segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+9 SET DFN=$PIECE($PIECE(IVMSEG,HLFS,4),$EXTRACT(HLECH))
+10 IF ('DFN!(DFN'=+DFN)!('$DATA(^DPT(+DFN,0))))
Begin DoDot:2
+11 SET HLERR="Invalid DFN"
DO ACK^IVMPREC
End DoDot:2
QUIT
+12 IF $PIECE(IVMSEG,HLFS,20)'=$PIECE(^DPT(DFN,0),"^",9)
SET HLERR="Couldn't match IVMSSN with DHCP SSN"
DO ACK^IVMPREC
QUIT
+13 ; save IVMDA for veteran PID segment
SET IVMDAP=IVMDA
+14 DO GET
IF IVMSEG1'="ZMT"
Begin DoDot:2
+15 SET HLERR="Missing ZMT segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+16 ; IVMMTDT - means test date
+17 ; DGLY - income year
+18 ; if Means Test not in DHCP don't upload IVM Means Test
+19 ; means test date from ZMT segment
SET IVMMTDT=$$FMDATE^HLFNC($PIECE(IVMSEG,HLFS,3))
+20 SET DGLY=$$LYR^DGMTSCU1(IVMMTDT)
+21 ; get means test to be updated
+22 NEW UPMTS
+23 SET MTDATE=-IVMMTDT
SET IVMMTIEN=""
SET MTFND=0
+24 FOR
SET IVMMTIEN=$ORDER(^DGMT(408.31,"AID",1,DFN,MTDATE,IVMMTIEN),-1)
if MTFND!(IVMMTIEN="")
QUIT
Begin DoDot:2
+25 ;EDB Z06 - Don't use this one
IF $$Z06MT^EASPTRN1(IVMMTIEN)
QUIT
+26 ; match site completing in case multiple tests for same date
+27 IF $PIECE(IVMSEG,HLFS,23)=$PIECE(^DGMT(408.31,IVMMTIEN,2),HLFS,5)
SET UPMTS=IVMMTIEN
SET MTFND=1
QUIT
End DoDot:2
+28 ; DGMTP is event driver variable
SET (IVMMT31,DGMTP)=$GET(^DGMT(408.31,UPMTS,0))
+29 IF $PIECE(IVMMT31,"^")'=IVMMTDT
Begin DoDot:2
+30 SET Y=IVMMTDT
XECUTE ^DD("DD")
+31 SET IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
+32 DO ERRBULL
DO MAIL^IVMUFNC()
+33 SET HLERR="Means test not in DHCP"
DO ACK^IVMPREC
+34 QUIT
End DoDot:2
QUIT
+35 IF $PIECE(IVMMT31,"^",23)=2
SET Y=IVMMTDT
XECUTE ^DD("DD")
SET HLERR="2nd means test sent for "_Y
DO ACK^IVMPREC
QUIT
+36 ; do not upload IVM means test if primary means test status is
+37 ; 3-no longer required
+38 ; or if hardship case
+39 SET IVMSTAT=$PIECE(IVMMT31,"^",3)
+40 IF IVMSTAT=3
SET HLERR="NOT UPLOADED no longer required"
DO ACK^IVMPREC
QUIT
+41 IF $PIECE(IVMMT31,"^",20)=1
SET HLERR="NOT UPLOADED hardship case"
DO ACK^IVMPREC
QUIT
+42 ;get MT signature and date/time edited info, update means test
+43 NEW DATA
+44 SET DATA(.29)=$PIECE(IVMSEG,HLFS,28)
SET DATA(2.02)=$$FMDATE^HLFNC($PIECE(IVMSEG,HLFS,26))
IF $DATA(DATA(.29))
Begin DoDot:2
+45 IF $$UPD^DGENDBS(408.31,UPMTS,.DATA)
End DoDot:2
+46 IF '$DATA(HLERR)
DO ACK^IVMPREC
+47 ;
+48 ; cleanup
+49 KILL DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,FMDATE,MTDATE
+50 QUIT
End DoDot:1
if 'IVMDA
QUIT
+51 QUIT
