- 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
