Routine: APCHS5A

APCHS5A ; IHS/CMI/LAB - PART 5A OF APCHS5 -- SUMMARY PRODUCTION COMPONENTS ;

 ;;2.0;IHS PCC SUITE;**2,5,21**;MAY 14, 2009;Build 34

MAID ;ENTRY POINT

 ; MEDICAID

 K APCHSITB

 ;<SETUP>

 S APCHSPDN=0 F APCHSQ=0:0 S APCHSPDN=$O(^AUPNMCD("B",APCHSPAT,APCHSPDN)) Q:APCHSPDN=""  D BMAID

 ;<DISPLAY>

 S APCHSI=0 F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSP=APCHSITB(APCHSI,APCHSJ) S APCHSPDN=$P(APCHSP,";",1),APCHSEDN=$P(APCHSP,";",2) D DMAID

 ;<CLEANUP>

MAIDX K APCHSCOV,APCHSDTL,APCHSDTN,APCHSDTS,APCHSEDN,APCHSI,APCHSIDN,APCHSINS,APCHSJ,APCHSN,APCHSPDN,APCHSUFF,Y,APCHSXDT,APCHSNM

BMAID Q:'$D(^AUPNMCD(APCHSPDN))

 S APCHSEDN=0 F APCHSQ=0:0 S APCHSEDN=$O(^AUPNMCD(APCHSPDN,11,APCHSEDN)) Q:'APCHSEDN  S APCHSP=^(APCHSEDN,0) S APCHSI=$P(^AUPNMCD(APCHSPDN,0),U,4)_"-"_$P(APCHSP,U,3),APCHSJ=9999999-$P(APCHSP,U,1) S APCHSITB(APCHSI,APCHSJ)=APCHSPDN_";"_APCHSEDN

DMAID ;

 S APCHSN=^AUPNMCD(APCHSPDN,0)

 S APCHSINS=$S($P(APCHSN,U,2):$P(^AUTNINS($P(APCHSN,U,2),0),U,1),1:"???") ;IHS/CMI/LAB - patch 6 prevent sbscr

 S APCHSNM=^AUPNMCD(APCHSPDN,11,APCHSEDN,0)

 S Y=$P(APCHSNM,U,1) X APCHSCVD S APCHSDTL=Y

 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 S (APCHSXDT,Y)=$P(APCHSNM,U,2) X APCHSCVD S APCHSDTN=Y

 I APCHSXDT="" S APCHSXDT=9999999

 Q:APCHSXDT<DT

 ;-- IHS/CMI/MAW end of mods

 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(Medicaid cont.)",!

 S X=$P($G(^DIC(5,+$P(APCHSN,U,4),0)),U,2) W $S(X="":"??",1:X)," ",APCHSINS,?32,$P(APCHSN,U,3)  ;IHS/ANMC/LJF 12/18/2002

 ;W $P(^DIC(5,$P(APCHSN,U,4),0),U,2)," ",APCHSINS,?32,$P(APCHSN,U,3)

 W ?49,$P(APCHSNM,U,3),?54,APCHSDTL,?72,APCHSDTN,!

 I $P(APCHSN,U,10)]"" W ?3,"Plan Name: ",$$VAL^XBDIQ1(9000004,APCHSPDN,.11),!

MCARE ;ENTRY POINT

 ; MEDICARE

 Q:'$D(^AUPNMCR(APCHSPAT))

 S APCHSN=^AUPNMCR(APCHSPAT,0)

 Q:'$D(^AUPNMCR(APCHSPAT,0))  ;CMI/LAB

 S APCHSINS=$S($P(APCHSN,U,2):$P(^AUTNINS($P(APCHSN,U,2),0),U,1),1:"???") ;IHS/CMI/LAB - prevent sbscr

 S APCHSUFF=$P(APCHSN,U,4) S:APCHSUFF]"" APCHSUFF=$P(^AUTTMCS(APCHSUFF,0),U,1)

 K APCHSITB

 S APCHSEDN=0 F APCHSQ=0:0 S APCHSEDN=$O(^AUPNMCR(APCHSPAT,11,APCHSEDN)) Q:APCHSEDN'=+APCHSEDN  S APCHSP=^(APCHSEDN,0) S APCHSI=$P(APCHSN,U,2)_"-"_$P(APCHSP,U,3),APCHSJ=9999999-$P(APCHSP,U,1) S APCHSITB(APCHSI,APCHSJ)=APCHSPAT_";"_APCHSEDN

 S APCHSI=0 F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSP=APCHSITB(APCHSI,APCHSJ) S APCHSPDN=$P(APCHSP,";",1),APCHSEDN=$P(APCHSP,";",2) D DMCARE

 W:$X'=0 !

DMCARE ;

 S APCHSNM=^AUPNMCR(APCHSPDN,11,APCHSEDN,0)

 S Y=$P(APCHSNM,U,1) X APCHSCVD S APCHSDTL=Y

 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 S (APCHSXDT,Y)=$P(APCHSNM,U,2) X APCHSCVD S APCHSDTN=Y

 I APCHSXDT="" S APCHSXDT=9999999

 Q:APCHSXDT<DT

 ;-- IHS/CMI/MAW end of mods

 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(Medicare cont.)",!

 ;W APCHSINS,?32,$P(APCHSN,U,3),?44,APCHSUFF

 W APCHSINS,?32,$$GETMCR^AGUTL(APCHSPAT),?44,APCHSUFF   ;IHS/CMI/LAB NMCI

 S APCHSCOV=$P(APCHSNM,U,3)

 S APCHSDTS="" I APCHSCOV="B" S Y=$P(^AUPNPAT(APCHSPAT,0),U,4) X APCHSCVD S APCHSDTS=Y

 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(Medicare cont.)",!

 W ?49,APCHSCOV,?54,APCHSDTL,?63,APCHSDTS,?72,APCHSDTN,!

 K APCHSXDT,APCHSNM

THIRD ;ENTRY POINT

 ; OTHER THIRD PARTY

 Q:$O(^AUPNPRVT(APCHSPAT,11,0))=""

 K APCHSITB

 S APCHSIDN=0 F APCHSQ=0:0 S APCHSIDN=$O(^AUPNPRVT(APCHSPAT,11,APCHSIDN)) Q:APCHSIDN'=+APCHSIDN  S APCHSP=^(APCHSIDN,0) S APCHSITB($P(APCHSP,U,1)_"-"_$P(APCHSP,U,3),9999999-$P(APCHSP,U,6))=APCHSIDN

 ;S APCHSI="" F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSIDN=APCHSITB(APCHSI,APCHSJ) D DTHIRD

 S APCHSI="" F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ="" F  S APCHSJ=$O(APCHSITB(APCHSI,APCHSJ)) Q:APCHSJ=""  S APCHSIDN=APCHSITB(APCHSI,APCHSJ) D DTHIRD

DTHIRD S APCHSN=^AUPNPRVT(APCHSPAT,11,APCHSIDN,0)

 Q:$P(APCHSN,U,1)=""

 S APCHSINS=$P(^AUTNINS($P(APCHSN,U,1),0),U,1)

 S Y=$P(APCHSN,U,6) X APCHSCVD S APCHSDTL=Y

 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 S (APCHSXDT,Y)=$P(APCHSN,U,7) X APCHSCVD S APCHSDTN=Y

 I APCHSXDT="" S APCHSXDT=9999999

 Q:APCHSXDT<DT

 ;-- IHS/CMI/MAW end of mods

 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(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.  If null, then get policy number

 ;from Policy Holder File

 S $P(APCHSN,U,2)=$P($G(^AUPNPRVT(APCHSPAT,11,APCHSIDN,2)),U)  ;member number

 I $P($G(APCHSN),U,2)']"",$P(APCHSN,U,8) S $P(APCHSN,U,2)=$P($G(^AUPN3PPH($P(APCHSN,U,8),0)),U,4)  ;policy number

 ;IHS/CMI/GRL  end of patch

 W APCHSINS,?32,$P(APCHSN,U,2),?49,$P(APCHSN,U,3),?54,APCHSDTL,?72,APCHSDTN,!

 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(3rd party cont.)",!

 I $P(APCHSN,U,8) W ?32,"Coverage Type: ",$$VAL^XBDIQ1(9000003.1,$P(APCHSN,U,8),.05),!

 K APCHSXDT

RR ;EP

 ; RAILROAD RETIREMENT

 Q:'$D(^AUPNRRE(APCHSPAT))

 S APCHSN=^AUPNRRE(APCHSPAT,0)

 S APCHSINS=$P(^AUTNINS($P(APCHSN,U,2),0),U,1)

 S APCHSUFF=$P(APCHSN,U,3)

 K APCHSITB

 S APCHSEDN=0 F APCHSQ=0:0 S APCHSEDN=$O(^AUPNRRE(APCHSPAT,11,APCHSEDN)) Q:APCHSEDN'=+APCHSEDN  S APCHSP=^(APCHSEDN,0) S APCHSI=$P(APCHSN,U,2)_"-"_$P(APCHSP,U,3),APCHSJ=9999999-$P(APCHSP,U,1) S APCHSITB(APCHSI,APCHSJ)=APCHSPAT_";"_APCHSEDN

 S APCHSI=0 F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSP=APCHSITB(APCHSI,APCHSJ) S APCHSPDN=$P(APCHSP,";",1),APCHSEDN=$P(APCHSP,";",2) D DRR

 W:$X'=0 !

DRR ;

 S APCHSNM=^AUPNRRE(APCHSPDN,11,APCHSEDN,0)

 S Y=$P(APCHSNM,U,1) X APCHSCVD S APCHSDTL=Y

 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 S (APCHSXDT,Y)=$P(APCHSNM,U,2) X APCHSCVD S APCHSDTN=Y

 I APCHSXDT="" S APCHSXDT=9999999

 Q:APCHSXDT<DT

 ;-- IHS/CMI/MAW end of mods

 S APCHSCOV=$P(APCHSNM,U,3)

 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(Railroad Retirement cont.)",!

 ;W APCHSINS,?32,$P(APCHSN,U,4),?44,APCHSUFF

 W APCHSINS,?32,$$GETRRE^AGUTL(APCHSPAT),?44,APCHSUFF

 W ?49,APCHSCOV,?54,APCHSDTL,?72,APCHSDTN,!

 K APCHSNM,APCHSXDT

APCHS5A   ; IHS/CMI/LAB - PART 5A OF APCHS5 -- SUMMARY PRODUCTION COMPONENTS ;

 +1       ;;2.0;IHS PCC SUITE;**2,5,21**;MAY 14, 2009;Build 34

 +2       ;

MAID      ;ENTRY POINT

 +1       ; MEDICAID

 +2        KILL APCHSITB

 +3       ;<SETUP>

 +4        SET APCHSPDN=0

           FOR APCHSQ=0:0

               SET APCHSPDN=$ORDER(^AUPNMCD("B",APCHSPAT,APCHSPDN))

               IF APCHSPDN=""

                   QUIT

               DO BMAID

 +5       ;<DISPLAY>

 +6        SET APCHSI=0

           FOR APCHSQ=0:0

               SET APCHSI=$ORDER(APCHSITB(APCHSI))

               IF APCHSI=""

                   QUIT

               SET APCHSJ=$ORDER(APCHSITB(APCHSI,0))

               SET APCHSP=APCHSITB(APCHSI,APCHSJ)

               SET APCHSPDN=$PIECE(APCHSP,";",1)

               SET APCHSEDN=$PIECE(APCHSP,";",2)

               DO DMAID

 +7       ;<CLEANUP>

MAIDX      KILL APCHSCOV,APCHSDTL,APCHSDTN,APCHSDTS,APCHSEDN,APCHSI,APCHSIDN,APCHSINS,APCHSJ,APCHSN,APCHSPDN,APCHSUFF,Y,APCHSXDT,APCHSNM

 +1        QUIT

BMAID      IF '$DATA(^AUPNMCD(APCHSPDN))

               QUIT

 +1        SET APCHSEDN=0

           FOR APCHSQ=0:0

               SET APCHSEDN=$ORDER(^AUPNMCD(APCHSPDN,11,APCHSEDN))

               IF 'APCHSEDN

                   QUIT

               SET APCHSP=^(APCHSEDN,0)

               SET APCHSI=$PIECE(^AUPNMCD(APCHSPDN,0),U,4)_"-"_$PIECE(APCHSP,U,3)

               SET APCHSJ=9999999-$PIECE(APCHSP,U,1)

               SET APCHSITB(APCHSI,APCHSJ)=APCHSPDN_";"_APCHSEDN

 +2        QUIT

DMAID     ;

 +1        SET APCHSN=^AUPNMCD(APCHSPDN,0)

 +2       ;IHS/CMI/LAB - patch 6 prevent sbscr

           SET APCHSINS=$SELECT($PIECE(APCHSN,U,2):$PIECE(^AUTNINS($PIECE(APCHSN,U,2),0),U,1),1:"???")

 +3        SET APCHSNM=^AUPNMCD(APCHSPDN,11,APCHSEDN,0)

 +4        SET Y=$PIECE(APCHSNM,U,1)

           XECUTE APCHSCVD

           SET APCHSDTL=Y

 +5       ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 +6        SET (APCHSXDT,Y)=$PIECE(APCHSNM,U,2)

           XECUTE APCHSCVD

           SET APCHSDTN=Y

 +7        IF APCHSXDT=""

               SET APCHSXDT=9999999

 +8        IF APCHSXDT<DT

               QUIT

 +9       ;-- IHS/CMI/MAW end of mods

 +10       XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               WRITE "(Medicaid cont.)",!

 +11      ;IHS/ANMC/LJF 12/18/2002

           SET X=$PIECE($GET(^DIC(5,+$PIECE(APCHSN,U,4),0)),U,2)

           WRITE $SELECT(X="":"??",1:X)," ",APCHSINS,?32,$PIECE(APCHSN,U,3)

 +12      ;W $P(^DIC(5,$P(APCHSN,U,4),0),U,2)," ",APCHSINS,?32,$P(APCHSN,U,3)

 +13       WRITE ?49,$PIECE(APCHSNM,U,3),?54,APCHSDTL,?72,APCHSDTN,!

 +14       IF $PIECE(APCHSN,U,10)]""

               WRITE ?3,"Plan Name: ",$$VAL^XBDIQ1(9000004,APCHSPDN,.11),!

 +15       QUIT

MCARE     ;ENTRY POINT

 +1       ; MEDICARE

 +2        IF '$DATA(^AUPNMCR(APCHSPAT))

               QUIT

 +3        SET APCHSN=^AUPNMCR(APCHSPAT,0)

 +4       ;CMI/LAB

           IF '$DATA(^AUPNMCR(APCHSPAT,0))

               QUIT

 +5       ;IHS/CMI/LAB - prevent sbscr

           SET APCHSINS=$SELECT($PIECE(APCHSN,U,2):$PIECE(^AUTNINS($PIECE(APCHSN,U,2),0),U,1),1:"???")

 +6        SET APCHSUFF=$PIECE(APCHSN,U,4)

           IF APCHSUFF]""

               SET APCHSUFF=$PIECE(^AUTTMCS(APCHSUFF,0),U,1)

 +7        KILL APCHSITB

 +8        SET APCHSEDN=0

           FOR APCHSQ=0:0

               SET APCHSEDN=$ORDER(^AUPNMCR(APCHSPAT,11,APCHSEDN))

               IF APCHSEDN'=+APCHSEDN

                   QUIT

               SET APCHSP=^(APCHSEDN,0)

               SET APCHSI=$PIECE(APCHSN,U,2)_"-"_$PIECE(APCHSP,U,3)

               SET APCHSJ=9999999-$PIECE(APCHSP,U,1)

               SET APCHSITB(APCHSI,APCHSJ)=APCHSPAT_";"_APCHSEDN

 +9        SET APCHSI=0

           FOR APCHSQ=0:0

               SET APCHSI=$ORDER(APCHSITB(APCHSI))

               IF APCHSI=""

                   QUIT

               SET APCHSJ=$ORDER(APCHSITB(APCHSI,0))

               SET APCHSP=APCHSITB(APCHSI,APCHSJ)

               SET APCHSPDN=$PIECE(APCHSP,";",1)

               SET APCHSEDN=$PIECE(APCHSP,";",2)

               DO DMCARE

 +10       IF $X'=0

               WRITE !

 +11       QUIT

DMCARE    ;

 +1        SET APCHSNM=^AUPNMCR(APCHSPDN,11,APCHSEDN,0)

 +2        SET Y=$PIECE(APCHSNM,U,1)

           XECUTE APCHSCVD

           SET APCHSDTL=Y

 +3       ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 +4        SET (APCHSXDT,Y)=$PIECE(APCHSNM,U,2)

           XECUTE APCHSCVD

           SET APCHSDTN=Y

 +5        IF APCHSXDT=""

               SET APCHSXDT=9999999

 +6        IF APCHSXDT<DT

               QUIT

 +7       ;-- IHS/CMI/MAW end of mods

 +8        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               WRITE "(Medicare cont.)",!

 +9       ;W APCHSINS,?32,$P(APCHSN,U,3),?44,APCHSUFF

 +10      ;IHS/CMI/LAB NMCI

           WRITE APCHSINS,?32,$$GETMCR^AGUTL(APCHSPAT),?44,APCHSUFF

 +11       SET APCHSCOV=$PIECE(APCHSNM,U,3)

 +12       SET APCHSDTS=""

           IF APCHSCOV="B"

               SET Y=$PIECE(^AUPNPAT(APCHSPAT,0),U,4)

               XECUTE APCHSCVD

               SET APCHSDTS=Y

 +13       XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               WRITE "(Medicare cont.)",!

 +14       WRITE ?49,APCHSCOV,?54,APCHSDTL,?63,APCHSDTS,?72,APCHSDTN,!

 +15       KILL APCHSXDT,APCHSNM

 +16       QUIT

THIRD     ;ENTRY POINT

 +1       ; OTHER THIRD PARTY

 +2        IF $ORDER(^AUPNPRVT(APCHSPAT,11,0))=""

               QUIT

 +3        KILL APCHSITB

 +4        SET APCHSIDN=0

           FOR APCHSQ=0:0

               SET APCHSIDN=$ORDER(^AUPNPRVT(APCHSPAT,11,APCHSIDN))

               IF APCHSIDN'=+APCHSIDN

                   QUIT

               SET APCHSP=^(APCHSIDN,0)

               SET APCHSITB($PIECE(APCHSP,U,1)_"-"_$PIECE(APCHSP,U,3),9999999-$PIECE(APCHSP,U,6))=APCHSIDN

 +5       ;S APCHSI="" F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSIDN=APCHSITB(APCHSI,APCHSJ) D DTHIRD

 +6        SET APCHSI=""

           FOR APCHSQ=0:0

               SET APCHSI=$ORDER(APCHSITB(APCHSI))

               IF APCHSI=""

                   QUIT

               SET APCHSJ=""

FOR

                   SET APCHSJ=$ORDER(APCHSITB(APCHSI,APCHSJ))

                   IF APCHSJ=""

                       QUIT

                   SET APCHSIDN=APCHSITB(APCHSI,APCHSJ)

                   DO DTHIRD

 +7        QUIT

DTHIRD     SET APCHSN=^AUPNPRVT(APCHSPAT,11,APCHSIDN,0)

 +1        IF $PIECE(APCHSN,U,1)=""

               QUIT

 +2        SET APCHSINS=$PIECE(^AUTNINS($PIECE(APCHSN,U,1),0),U,1)

 +3        SET Y=$PIECE(APCHSN,U,6)

           XECUTE APCHSCVD

           SET APCHSDTL=Y

 +4       ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 +5        SET (APCHSXDT,Y)=$PIECE(APCHSN,U,7)

           XECUTE APCHSCVD

           SET APCHSDTN=Y

 +6        IF APCHSXDT=""

               SET APCHSXDT=9999999

 +7        IF APCHSXDT<DT

               QUIT

 +8       ;-- IHS/CMI/MAW end of mods

 +9        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               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.  If null, then get policy number

 +12      ;from Policy Holder File

 +13      ;member number

           SET $PIECE(APCHSN,U,2)=$PIECE($GET(^AUPNPRVT(APCHSPAT,11,APCHSIDN,2)),U)

 +14      ;policy number

           IF $PIECE($GET(APCHSN),U,2)']""

               IF $PIECE(APCHSN,U,8)

                   SET $PIECE(APCHSN,U,2)=$PIECE($GET(^AUPN3PPH($PIECE(APCHSN,U,8),0)),U,4)

 +15      ;IHS/CMI/GRL  end of patch

 +16       WRITE APCHSINS,?32,$PIECE(APCHSN,U,2),?49,$PIECE(APCHSN,U,3),?54,APCHSDTL,?72,APCHSDTN,!

 +17       XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               WRITE "(3rd party cont.)",!

 +18       IF $PIECE(APCHSN,U,8)

               WRITE ?32,"Coverage Type: ",$$VAL^XBDIQ1(9000003.1,$PIECE(APCHSN,U,8),.05),!

 +19       KILL APCHSXDT

 +20       QUIT

RR        ;EP

 +1       ; RAILROAD RETIREMENT

 +2        IF '$DATA(^AUPNRRE(APCHSPAT))

               QUIT

 +3        SET APCHSN=^AUPNRRE(APCHSPAT,0)

 +4        SET APCHSINS=$PIECE(^AUTNINS($PIECE(APCHSN,U,2),0),U,1)

 +5        SET APCHSUFF=$PIECE(APCHSN,U,3)

 +6        KILL APCHSITB

 +7        SET APCHSEDN=0

           FOR APCHSQ=0:0

               SET APCHSEDN=$ORDER(^AUPNRRE(APCHSPAT,11,APCHSEDN))

               IF APCHSEDN'=+APCHSEDN

                   QUIT

               SET APCHSP=^(APCHSEDN,0)

               SET APCHSI=$PIECE(APCHSN,U,2)_"-"_$PIECE(APCHSP,U,3)

               SET APCHSJ=9999999-$PIECE(APCHSP,U,1)

               SET APCHSITB(APCHSI,APCHSJ)=APCHSPAT_";"_APCHSEDN

 +8        SET APCHSI=0

           FOR APCHSQ=0:0

               SET APCHSI=$ORDER(APCHSITB(APCHSI))

               IF APCHSI=""

                   QUIT

               SET APCHSJ=$ORDER(APCHSITB(APCHSI,0))

               SET APCHSP=APCHSITB(APCHSI,APCHSJ)

               SET APCHSPDN=$PIECE(APCHSP,";",1)

               SET APCHSEDN=$PIECE(APCHSP,";",2)

               DO DRR

 +9        IF $X'=0

               WRITE !

 +10       QUIT

DRR       ;

 +1        SET APCHSNM=^AUPNRRE(APCHSPDN,11,APCHSEDN,0)

 +2        SET Y=$PIECE(APCHSNM,U,1)

           XECUTE APCHSCVD

           SET APCHSDTL=Y

 +3       ;-- IHS/CMI/MAW add set of exp date variable, quit if not current

 +4        SET (APCHSXDT,Y)=$PIECE(APCHSNM,U,2)

           XECUTE APCHSCVD

           SET APCHSDTN=Y

 +5        IF APCHSXDT=""

               SET APCHSXDT=9999999

 +6        IF APCHSXDT<DT

               QUIT

 +7       ;-- IHS/CMI/MAW end of mods

 +8        SET APCHSCOV=$PIECE(APCHSNM,U,3)

 +9        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT

           IF APCHSNPG

               WRITE "(Railroad Retirement cont.)",!

 +10      ;W APCHSINS,?32,$P(APCHSN,U,4),?44,APCHSUFF

 +11       WRITE APCHSINS,?32,$$GETRRE^AGUTL(APCHSPAT),?44,APCHSUFF

 +12       WRITE ?49,APCHSCOV,?54,APCHSDTL,?72,APCHSDTN,!

 +13       KILL APCHSNM,APCHSXDT

 +14       QUIT

APCHS5A.m