BHSINSUR ;IHS/CIA/MGH - Health Summary for Insurance ;09-Aug-2018 16:44;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**4,15**;Mar 17, 2006;Build 8
;===================================================================
;Taken from APCHS5A
; IHS/TUCSON/LAB - PART 5A OF APCHS5 -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**3,6,8,9**;JUN 24, 1997
;VA health summary for IHS health summary insurance component
;Patch 15 changes for insurance (medicare and RR)
;
MAID ;ENTRY POINT
; MEDICAID
K BHSITB,X
;<SETUP>
S BHSPDN=0 F BHSQ=0:0 S BHSPDN=$O(^AUPNMCD("B",BHSPAT,BHSPDN)) Q:BHSPDN="" D BMAID
;<DISPLAY>
S BHSI=0 F BHSQ=0:0 S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" S BHSJ=$O(BHSITB(BHSI,0)) S BHSP=BHSITB(BHSI,BHSJ) S BHSPDN=$P(BHSP,";",1),BHSEDN=$P(BHSP,";",2) D DMAID
;<CLEANUP>
MAIDX K BHSCOV,BHSDTL,BHSDTN,BHSDTS,BHSEDN,BHSI,BHSIDN,BHSINS,BHSJ,BHSN,BHSPDN,BHSUFF,Y,BHSXDT,BHSNM,BHSP,BHSQ
Q
BMAID Q:'$D(^AUPNMCD(BHSPDN))
S BHSEDN=0 F BHSQ=0:0 S BHSEDN=$O(^AUPNMCD(BHSPDN,11,BHSEDN)) Q:'BHSEDN D
.S BHSP=$G(^AUPNMCD(BHSEDN,0)) S BHSI=$P(^AUPNMCD(BHSPDN,0),U,4)_"-"_$P(BHSP,U,3),BHSJ=9999999-$P(BHSP,U,1) S BHSITB(BHSI,BHSJ)=BHSPDN_";"_BHSEDN
Q
DMAID ;
S BHSN=^AUPNMCD(BHSPDN,0)
S BHSINS=$S($P(BHSN,U,2):$P(^AUTNINS($P(BHSN,U,2),0),U,1),1:"???") ;IHS/CMI/LAB - patch 6 prevent sbscr
S BHSNM=^AUPNMCD(BHSPDN,11,BHSEDN,0)
S X=$P(BHSNM,U,1) D REGDT4^GMTSU S BHSDTL=X
;-- IHS/CMI/MAW add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSNM,U,2) D REGDT4^GMTSU S BHSDTN=X
I BHSXDT="" S BHSXDT=9999999
Q:BHSXDT<DT
;-- IHS/CMI/MAW end of mods
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG "(Medicaid cont.)",!
S X=$P($G(^DIC(5,+$P(BHSN,U,4),0)),U,2) W $S(X="":"??",1:X)," ",$E(BHSINS,1,23),?25,$P(BHSN,U,3) ;IHS/ANMC/LJF 12/18/2002
W ?40,$P(BHSNM,U,3),?48,BHSDTL,?70,BHSDTN,!
I $P(BHSN,U,10)]"" W ?3,"Plan Name: ",$$VAL^XBDIQ1(9000004,BHSPDN,.11),!
Q
MCARE ;ENTRY POINT
; MEDICARE
Q:'$D(^AUPNMCR(BHSPAT))
S BHSN=^AUPNMCR(BHSPAT,0)
Q:'$D(^AUPNMCR(BHSPAT,0)) ;CMI/LAB
S BHSINS=$S($P(BHSN,U,2):$P(^AUTNINS($P(BHSN,U,2),0),U,1),1:"???") ;IHS/CMI/LAB - prevent sbscr
S BHSUFF=$P(BHSN,U,4) S:BHSUFF]"" BHSUFF=$P(^AUTTMCS(BHSUFF,0),U,1)
K BHSITB
S BHSEDN=0 F BHSQ=0:0 S BHSEDN=$O(^AUPNMCR(BHSPAT,11,BHSEDN)) Q:BHSEDN'=+BHSEDN S BHSP=^(BHSEDN,0) S BHSI=$P(BHSN,U,2)_"-"_$P(BHSP,U,3),BHSJ=9999999-$P(BHSP,U,1) S BHSITB(BHSI,BHSJ)=BHSPAT_";"_BHSEDN
S BHSI=0 F BHSQ=0:0 S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ=$O(BHSITB(BHSI,0)) S BHSP=BHSITB(BHSI,BHSJ)
.S BHSPDN=$P(BHSP,";",1),BHSEDN=$P(BHSP,";",2) D DMCARE
W:$X'=0 !
Q
DMCARE ;
N INS,DNAME
S BHSNM=^AUPNMCR(BHSPDN,11,BHSEDN,0)
S X=$P(BHSNM,U,1) D REGDT4^GMTSU S BHSDTL=X
;-- IHS/CMI/MAW add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSNM,U,2) D REGDT4^GMTSU S BHSDTN=X
I BHSXDT="" S BHSXDT=9999999
Q:BHSXDT<DT
;-- IHS/CMI/MAW end of mods
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG "(Medicare cont.)",!
S BHSIEN=$$GETMCR^AGUTL(BHSPAT) ;IHS/MSC/MGH Patch 15
I '+BHSIEN S BHSIEN=$P(BHSN,U,3)
E S BHSUFF=""
S BHSCOV=$P(BHSNM,U,3)
I BHSCOV="D" D
.S INS=$$GET1^DIQ(9999999.18,$P(BHSNM,U,4),.01)
.S DNUM=$P(BHSNM,U,6)
.I DNUM'="" S BHSINS="MC/"_INS,BHSIEN=DNUM
W $E(BHSINS,1,23),?25,BHSIEN,?37,$$GET1^DIQ(9999999.32,BHSUFF,.01)
S BHSDTS="" I BHSCOV="B" S X=$P(^AUPNPAT(BHSPAT,0),U,4) D REGDT4^GMTSU S BHSDTS=X
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG "(Medicare cont.)",!
W ?40,$E(BHSCOV,1,7),?48,BHSDTL,?59,BHSDTS,?70,BHSDTN,!
K BHSXDT,BHSNM,BHSIEN
Q
THIRD ;ENTRY POINT
; OTHER THIRD PARTY
Q:$O(^AUPNPRVT(BHSPAT,11,0))=""
K BHSITB
S BHSIDN=0 F BHSQ=0:0 S BHSIDN=$O(^AUPNPRVT(BHSPAT,11,BHSIDN)) Q:BHSIDN'=+BHSIDN S BHSP=^(BHSIDN,0) S BHSITB($P(BHSP,U,1)_"-"_$P(BHSP,U,3),9999999-$P(BHSP,U,6))=BHSIDN
S BHSI="" F BHSQ=0:0 S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ="" F S BHSJ=$O(BHSITB(BHSI,BHSJ)) Q:BHSJ="" D
..S BHSIDN=BHSITB(BHSI,BHSJ) D DTHIRD
Q
DTHIRD S BHSN=^AUPNPRVT(BHSPAT,11,BHSIDN,0)
Q:$P(BHSN,U,1)=""
S BHSINS=$P(^AUTNINS($P(BHSN,U,1),0),U,1)
S X=$P(BHSN,U,6) D REGDT4^GMTSU S BHSDTL=X
;-- IHS/CMI/MAW add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSN,U,7) D REGDT4^GMTSU S BHSDTN=X
I BHSXDT="" S BHSXDT=9999999
Q:BHSXDT<DT
;-- IHS/CMI/MAW end of mods
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG "(3rd party cont.)",!
;IHS/CMI/GRL policy number field of Private Insurance Eligible is obsolete. Per Adrian Lujan,
;following code looks at the Member Number field of Insurer multiple.
;from Policy Holder File
S $P(BHSN,U,2)=$P($G(^AUPNPRVT(BHSPAT,11,BHSIDN,2)),U) ;member number
I $P($G(BHSN),U,2)']"",$P(BHSN,U,8) S $P(BHSN,U,2)=$P($G(^AUPN3PPH($P(BHSN,U,8),0)),U,4) ;policy number
;IHS/CMI/GRL end of patch
W $E(BHSINS,1,24),?25,$P(BHSN,U,2),?40,$P(BHSN,U,3),?48,BHSDTL,?70,BHSDTN,!
I $P(BHSN,U,8) W ?40,"Coverage Type: ",$$VAL^XBDIQ1(9000003.1,$P(BHSN,U,8),.05),!
K BHSXDT
Q
RR ;EP
; RAILROAD RETIREMENT
Q:'$D(^AUPNRRE(BHSPAT))
S BHSN=^AUPNRRE(BHSPAT,0)
S BHSINS=$P(^AUTNINS($P(BHSN,U,2),0),U,1)
S BHSUFF=$P(BHSN,U,3)
K BHSITB
S BHSEDN=0 F BHSQ=0:0 S BHSEDN=$O(^AUPNRRE(BHSPAT,11,BHSEDN)) Q:BHSEDN'=+BHSEDN S BHSP=^(BHSEDN,0) S BHSI=$P(BHSN,U,2)_"-"_$P(BHSP,U,3),BHSJ=9999999-$P(BHSP,U,1) S BHSITB(BHSI,BHSJ)=BHSPAT_";"_BHSEDN
S BHSI=0 F BHSQ=0:0 S BHSI=$O(BHSITB(BHSI)) Q:BHSI="" D
.S BHSJ=$O(BHSITB(BHSI,0)) S BHSP=BHSITB(BHSI,BHSJ)
.S BHSPDN=$P(BHSP,";",1),BHSEDN=$P(BHSP,";",2) D DRR
W:$X'=0 !
Q
DRR ;
S BHSNM=^AUPNRRE(BHSPDN,11,BHSEDN,0)
S X=$P(BHSNM,U,1) D REGDT4^GMTSU S BHSDTL=X
;-- IHS/CMI/MAW add set of exp date variable, quit if not current
S (BHSXDT,X)=$P(BHSNM,U,2) D REGDT4^GMTSU S BHSDTN=X
I BHSXDT="" S BHSXDT=9999999
Q:BHSXDT<DT
;-- IHS/CMI/MAW end of mods
S BHSIEN=$$GETRRE^AGUTL(BHSPAT) ;IHS/MSC/MGH Patch 15
I BHSIEN="" S BHSIEN=$P(BHSN,U,4)
S BHSCOV=$P(BHSNM,U,3)
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG "(Railroad Retirement cont.)",!
W $E(BHSINS,1,23),?25,BHSIEN
W ?40,$E(BHSCOV,1,7),?48,BHSDTL,?70,BHSDTN,!
K BHSNM,BHSXDT
Q
BHSINSUR ;IHS/CIA/MGH - Health Summary for Insurance ;09-Aug-2018 16:44;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4,15**;Mar 17, 2006;Build 8
+2 ;===================================================================
+3 ;Taken from APCHS5A
+4 ; IHS/TUCSON/LAB - PART 5A OF APCHS5 -- SUMMARY PRODUCTION COMPONENTS ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;**3,6,8,9**;JUN 24, 1997
+6 ;VA health summary for IHS health summary insurance component
+7 ;Patch 15 changes for insurance (medicare and RR)
+8 ;
MAID ;ENTRY POINT
+1 ; MEDICAID
+2 KILL BHSITB,X
+3 ;<SETUP>
+4 SET BHSPDN=0
FOR BHSQ=0:0
SET BHSPDN=$ORDER(^AUPNMCD("B",BHSPAT,BHSPDN))
IF BHSPDN=""
QUIT
DO BMAID
+5 ;<DISPLAY>
+6 SET BHSI=0
FOR BHSQ=0:0
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
SET BHSJ=$ORDER(BHSITB(BHSI,0))
SET BHSP=BHSITB(BHSI,BHSJ)
SET BHSPDN=$PIECE(BHSP,";",1)
SET BHSEDN=$PIECE(BHSP,";",2)
DO DMAID
+7 ;<CLEANUP>
MAIDX KILL BHSCOV,BHSDTL,BHSDTN,BHSDTS,BHSEDN,BHSI,BHSIDN,BHSINS,BHSJ,BHSN,BHSPDN,BHSUFF,Y,BHSXDT,BHSNM,BHSP,BHSQ
+1 QUIT
BMAID IF '$DATA(^AUPNMCD(BHSPDN))
QUIT
+1 SET BHSEDN=0
FOR BHSQ=0:0
SET BHSEDN=$ORDER(^AUPNMCD(BHSPDN,11,BHSEDN))
IF 'BHSEDN
QUIT
Begin DoDot:1
+2 SET BHSP=$GET(^AUPNMCD(BHSEDN,0))
SET BHSI=$PIECE(^AUPNMCD(BHSPDN,0),U,4)_"-"_$PIECE(BHSP,U,3)
SET BHSJ=9999999-$PIECE(BHSP,U,1)
SET BHSITB(BHSI,BHSJ)=BHSPDN_";"_BHSEDN
End DoDot:1
+3 QUIT
DMAID ;
+1 SET BHSN=^AUPNMCD(BHSPDN,0)
+2 ;IHS/CMI/LAB - patch 6 prevent sbscr
SET BHSINS=$SELECT($PIECE(BHSN,U,2):$PIECE(^AUTNINS($PIECE(BHSN,U,2),0),U,1),1:"???")
+3 SET BHSNM=^AUPNMCD(BHSPDN,11,BHSEDN,0)
+4 SET X=$PIECE(BHSNM,U,1)
DO REGDT4^GMTSU
SET BHSDTL=X
+5 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
+6 SET (BHSXDT,X)=$PIECE(BHSNM,U,2)
DO REGDT4^GMTSU
SET BHSDTN=X
+7 IF BHSXDT=""
SET BHSXDT=9999999
+8 IF BHSXDT<DT
QUIT
+9 ;-- IHS/CMI/MAW end of mods
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "(Medicaid cont.)",!
+11 ;IHS/ANMC/LJF 12/18/2002
SET X=$PIECE($GET(^DIC(5,+$PIECE(BHSN,U,4),0)),U,2)
WRITE $SELECT(X="":"??",1:X)," ",$EXTRACT(BHSINS,1,23),?25,$PIECE(BHSN,U,3)
+12 WRITE ?40,$PIECE(BHSNM,U,3),?48,BHSDTL,?70,BHSDTN,!
+13 IF $PIECE(BHSN,U,10)]""
WRITE ?3,"Plan Name: ",$$VAL^XBDIQ1(9000004,BHSPDN,.11),!
+14 QUIT
MCARE ;ENTRY POINT
+1 ; MEDICARE
+2 IF '$DATA(^AUPNMCR(BHSPAT))
QUIT
+3 SET BHSN=^AUPNMCR(BHSPAT,0)
+4 ;CMI/LAB
IF '$DATA(^AUPNMCR(BHSPAT,0))
QUIT
+5 ;IHS/CMI/LAB - prevent sbscr
SET BHSINS=$SELECT($PIECE(BHSN,U,2):$PIECE(^AUTNINS($PIECE(BHSN,U,2),0),U,1),1:"???")
+6 SET BHSUFF=$PIECE(BHSN,U,4)
IF BHSUFF]""
SET BHSUFF=$PIECE(^AUTTMCS(BHSUFF,0),U,1)
+7 KILL BHSITB
+8 SET BHSEDN=0
FOR BHSQ=0:0
SET BHSEDN=$ORDER(^AUPNMCR(BHSPAT,11,BHSEDN))
IF BHSEDN'=+BHSEDN
QUIT
SET BHSP=^(BHSEDN,0)
SET BHSI=$PIECE(BHSN,U,2)_"-"_$PIECE(BHSP,U,3)
SET BHSJ=9999999-$PIECE(BHSP,U,1)
SET BHSITB(BHSI,BHSJ)=BHSPAT_";"_BHSEDN
+9 SET BHSI=0
FOR BHSQ=0:0
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+10 SET BHSJ=$ORDER(BHSITB(BHSI,0))
SET BHSP=BHSITB(BHSI,BHSJ)
+11 SET BHSPDN=$PIECE(BHSP,";",1)
SET BHSEDN=$PIECE(BHSP,";",2)
DO DMCARE
End DoDot:1
+12 IF $X'=0
WRITE !
+13 QUIT
DMCARE ;
+1 NEW INS,DNAME
+2 SET BHSNM=^AUPNMCR(BHSPDN,11,BHSEDN,0)
+3 SET X=$PIECE(BHSNM,U,1)
DO REGDT4^GMTSU
SET BHSDTL=X
+4 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
+5 SET (BHSXDT,X)=$PIECE(BHSNM,U,2)
DO REGDT4^GMTSU
SET BHSDTN=X
+6 IF BHSXDT=""
SET BHSXDT=9999999
+7 IF BHSXDT<DT
QUIT
+8 ;-- IHS/CMI/MAW end of mods
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "(Medicare cont.)",!
+10 ;IHS/MSC/MGH Patch 15
SET BHSIEN=$$GETMCR^AGUTL(BHSPAT)
+11 IF '+BHSIEN
SET BHSIEN=$PIECE(BHSN,U,3)
+12 IF '$TEST
SET BHSUFF=""
+13 SET BHSCOV=$PIECE(BHSNM,U,3)
+14 IF BHSCOV="D"
Begin DoDot:1
+15 SET INS=$$GET1^DIQ(9999999.18,$PIECE(BHSNM,U,4),.01)
+16 SET DNUM=$PIECE(BHSNM,U,6)
+17 IF DNUM'=""
SET BHSINS="MC/"_INS
SET BHSIEN=DNUM
End DoDot:1
+18 WRITE $EXTRACT(BHSINS,1,23),?25,BHSIEN,?37,$$GET1^DIQ(9999999.32,BHSUFF,.01)
+19 SET BHSDTS=""
IF BHSCOV="B"
SET X=$PIECE(^AUPNPAT(BHSPAT,0),U,4)
DO REGDT4^GMTSU
SET BHSDTS=X
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "(Medicare cont.)",!
+21 WRITE ?40,$EXTRACT(BHSCOV,1,7),?48,BHSDTL,?59,BHSDTS,?70,BHSDTN,!
+22 KILL BHSXDT,BHSNM,BHSIEN
+23 QUIT
THIRD ;ENTRY POINT
+1 ; OTHER THIRD PARTY
+2 IF $ORDER(^AUPNPRVT(BHSPAT,11,0))=""
QUIT
+3 KILL BHSITB
+4 SET BHSIDN=0
FOR BHSQ=0:0
SET BHSIDN=$ORDER(^AUPNPRVT(BHSPAT,11,BHSIDN))
IF BHSIDN'=+BHSIDN
QUIT
SET BHSP=^(BHSIDN,0)
SET BHSITB($PIECE(BHSP,U,1)_"-"_$PIECE(BHSP,U,3),9999999-$PIECE(BHSP,U,6))=BHSIDN
+5 SET BHSI=""
FOR BHSQ=0:0
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+6 SET BHSJ=""
FOR
SET BHSJ=$ORDER(BHSITB(BHSI,BHSJ))
IF BHSJ=""
QUIT
Begin DoDot:2
+7 SET BHSIDN=BHSITB(BHSI,BHSJ)
DO DTHIRD
End DoDot:2
End DoDot:1
+8 QUIT
DTHIRD SET BHSN=^AUPNPRVT(BHSPAT,11,BHSIDN,0)
+1 IF $PIECE(BHSN,U,1)=""
QUIT
+2 SET BHSINS=$PIECE(^AUTNINS($PIECE(BHSN,U,1),0),U,1)
+3 SET X=$PIECE(BHSN,U,6)
DO REGDT4^GMTSU
SET BHSDTL=X
+4 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
+5 SET (BHSXDT,X)=$PIECE(BHSN,U,7)
DO REGDT4^GMTSU
SET BHSDTN=X
+6 IF BHSXDT=""
SET BHSXDT=9999999
+7 IF BHSXDT<DT
QUIT
+8 ;-- IHS/CMI/MAW end of mods
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "(3rd party cont.)",!
+10 ;IHS/CMI/GRL policy number field of Private Insurance Eligible is obsolete. Per Adrian Lujan,
+11 ;following code looks at the Member Number field of Insurer multiple.
+12 ;from Policy Holder File
+13 ;member number
SET $PIECE(BHSN,U,2)=$PIECE($GET(^AUPNPRVT(BHSPAT,11,BHSIDN,2)),U)
+14 ;policy number
IF $PIECE($GET(BHSN),U,2)']""
IF $PIECE(BHSN,U,8)
SET $PIECE(BHSN,U,2)=$PIECE($GET(^AUPN3PPH($PIECE(BHSN,U,8),0)),U,4)
+15 ;IHS/CMI/GRL end of patch
+16 WRITE $EXTRACT(BHSINS,1,24),?25,$PIECE(BHSN,U,2),?40,$PIECE(BHSN,U,3),?48,BHSDTL,?70,BHSDTN,!
+17 IF $PIECE(BHSN,U,8)
WRITE ?40,"Coverage Type: ",$$VAL^XBDIQ1(9000003.1,$PIECE(BHSN,U,8),.05),!
+18 KILL BHSXDT
+19 QUIT
RR ;EP
+1 ; RAILROAD RETIREMENT
+2 IF '$DATA(^AUPNRRE(BHSPAT))
QUIT
+3 SET BHSN=^AUPNRRE(BHSPAT,0)
+4 SET BHSINS=$PIECE(^AUTNINS($PIECE(BHSN,U,2),0),U,1)
+5 SET BHSUFF=$PIECE(BHSN,U,3)
+6 KILL BHSITB
+7 SET BHSEDN=0
FOR BHSQ=0:0
SET BHSEDN=$ORDER(^AUPNRRE(BHSPAT,11,BHSEDN))
IF BHSEDN'=+BHSEDN
QUIT
SET BHSP=^(BHSEDN,0)
SET BHSI=$PIECE(BHSN,U,2)_"-"_$PIECE(BHSP,U,3)
SET BHSJ=9999999-$PIECE(BHSP,U,1)
SET BHSITB(BHSI,BHSJ)=BHSPAT_";"_BHSEDN
+8 SET BHSI=0
FOR BHSQ=0:0
SET BHSI=$ORDER(BHSITB(BHSI))
IF BHSI=""
QUIT
Begin DoDot:1
+9 SET BHSJ=$ORDER(BHSITB(BHSI,0))
SET BHSP=BHSITB(BHSI,BHSJ)
+10 SET BHSPDN=$PIECE(BHSP,";",1)
SET BHSEDN=$PIECE(BHSP,";",2)
DO DRR
End DoDot:1
+11 IF $X'=0
WRITE !
+12 QUIT
DRR ;
+1 SET BHSNM=^AUPNRRE(BHSPDN,11,BHSEDN,0)
+2 SET X=$PIECE(BHSNM,U,1)
DO REGDT4^GMTSU
SET BHSDTL=X
+3 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
+4 SET (BHSXDT,X)=$PIECE(BHSNM,U,2)
DO REGDT4^GMTSU
SET BHSDTN=X
+5 IF BHSXDT=""
SET BHSXDT=9999999
+6 IF BHSXDT<DT
QUIT
+7 ;-- IHS/CMI/MAW end of mods
+8 ;IHS/MSC/MGH Patch 15
SET BHSIEN=$$GETRRE^AGUTL(BHSPAT)
+9 IF BHSIEN=""
SET BHSIEN=$PIECE(BHSN,U,4)
+10 SET BHSCOV=$PIECE(BHSNM,U,3)
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "(Railroad Retirement cont.)",!
+12 WRITE $EXTRACT(BHSINS,1,23),?25,BHSIEN
+13 WRITE ?40,$EXTRACT(BHSCOV,1,7),?48,BHSDTL,?70,BHSDTN,!
+14 KILL BHSNM,BHSXDT
+15 QUIT
