- ACHSRP31 ; IHS/ITSC/PMF - PRINT CHS (43 & 64) FORMS (2/2) ;
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,27**;JUN 11,2001;Build 43
- ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
- ;ACHS*3.1*27 11.14.17 IHS.OIT.FCJ CHANGE FOR NEW MEDICARE NUMBER
- ;
- I $$PARM^ACHS(2,16)'="Y" W !!!!
- ;
- EN ;EP - From CHEF report.
- I $G(DFN)="" W !!,"DFN variable MUST be defined when entering this routine!!" Q
- ;
- W !!?ACHSTAB,"Type of Coverage",?30,"Policy #",?55,"Cov. type EligDt TermDt",!?ACHSTAB,"----------------",?30,"--------",?55,"--------- ------ ------"
- ;
- ;LETS LOOK AT POSSIBLE MEDICARE COVERAGE
- MCR ;
- G:'$D(^AUPNMCR(DFN)) MCD
- ;G MCD:'$P($G(^AUPNMCR(DFN,0)),U,3) ;ACHS*3.1*27 NEW NUMBER STORED IN PAT REG
- ;S X=$J("",ACHSTAB)_$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U)
- I $P($G(^AUPNMCR(DFN,0),"UNDEFINED"),U,2)'="" D
- .S X=$J("",ACHSTAB)_$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U)
- E S X=$J("",ACHSTAB)
- S X=X_$J("",30-$L(X))
- ;ACHS*3.1*27 MODIFIED NXT SECTION FOR NEW MBI AND CHECK FOR "D" COVERAGE AND ELIG DATES
- S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
- I +ACHSMBI<1 S ACHSMBI=$P(^AUPNMCR(DFN,0),U,3) I $P(^(0),U,4),$D(^AUTTMCS($P(^(0),U,4),0)) S ACHSMBI=ACHSMBI_$P(^(0),U)
- ;GO THRU 'MEDICARE ELIGIBLE' FILE
- S I=0
- F S I=$O(^AUPNMCR(DFN,11,I)) Q:+I=0 D
- .I $G(ACHSEDOS) Q:ACHSEDOS<$P($G(^AUPNMCR(DFN,11,I,0)),U)
- .I $G(ACHSEDOS),$P($G(^AUPNMCR(DFN,11,I,0)),U,2)'="" Q:ACHSEDOS>$P($G(^AUPNMCR(DFN,11,I,0)),U,2)
- .W !,X
- .I $P($G(^AUPNMCR(DFN,11,I,0)),U,3)?1"D" W $P($G(^AUPNMCR(DFN,11,I,0)),U,6) ;COVERAGE TYPE OF "D"
- .E W ACHSMBI
- .W ?60,$P($G(^AUPNMCR(DFN,11,I,0)),U,3) ;'COVERAGE TYPE'
- .W ?65,$$MDY($P($G(^AUPNMCR(DFN,11,I,0)),U)) ;'ELIG. DATE'
- .W ?72,$$MDY($P($G(^AUPNMCR(DFN,11,I,0)),U,2)) ;'ELIG. END DATE'
- ;
- ;LETS LOOK AT POSSIBLE MEDICAID COVERAGE
- MCD ;
- G RRE:'$D(^AUPNMCD("B",DFN))
- K ^TMP("ACHSRP31",$J,"MCD")
- F I=0:0 S I=$O(^AUPNMCD("B",DFN,I)) Q:'I F JJ=0:0 S JJ=$O(^AUPNMCD(I,11,JJ)) Q:'JJ D
- .S ^TMP("ACHSRP31",$J,"MCD",9999999-JJ)=$G(^AUPNMCD(I,11,JJ,0))
- .S $P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,4,6)=$P($G(^AUPNMCD(I,0)),U,2,4)
- ;
- S JJ=0,DAT=""
- F ACHS=1:1:4 S JJ=$O(^TMP("ACHSRP31",$J,"MCD",JJ)) Q:'JJ I $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)]"",$D(^DIC(5,$P(^(JJ),U,6),0)) S $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)=$P(^(0),U,2)
- S I=0
- ;ACHS*3.1*27 REWROTE TO TST FOR ELIG DATES
- F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
- .S DAT=^TMP("ACHSRP31",$J,"MCD",I)
- .I $G(ACHSEDOS) Q:ACHSEDOS<($P(DAT,U))
- .I $G(ACHSEDOS),$P(DAT,U,2)'="" Q:ACHSEDOS>($P(DAT,U,2))
- .W !?ACHSTAB,$P(^AUTNINS($P(DAT,U,4),0),U)
- .W ?30,$P(DAT,U,5),$P(DAT,U,6),?60,$P(DAT,U,3),?65,$$MDY($P(DAT,U)),?72,$$MDY($P(DAT,U,2))
- K ^TMP("ACHSRP31",$J,"MCD")
- RRE ;
- G PVT:'$D(^AUPNRRE(DFN,0))
- ;ACHS*3.1*27 REWROTE TO TST FOR ELIG DATES AND PRINT MBI
- ;******LOOP THRU RAILROAD ELIGIBLE FILE
- S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
- I +ACHSMBI<1 D
- .S ACHSMBI=""
- .S:$P($G(^AUPNRRE(DFN,0)),U,3)'="" ACHSMBI=$P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U)
- .S ACHSMBI=ACHSMBI_$P($G(^AUPNRRE(DFN,0)),U,4) ;PRNT PREFIX FOR OLD NUMBER
- S I=0
- F S I=$O(^AUPNRRE(DFN,11,I)) Q:I'?1N.N D
- .S DAT=^AUPNRRE(DFN,11,I,0)
- .I $G(ACHSEDOS) Q:ACHSEDOS<$P(DAT,U)
- .I $G(ACHSEDOS),$P(DAT,U,2)'="" Q:ACHSEDOS>($P(DAT,U,2))
- .W !?ACHSTAB
- .W:$P($G(^AUPNRRE(DFN,0)),U,2)'="" $P($G(^AUTNINS($P(^AUPNRRE(DFN,0),U,2),0)),U),?30
- .W ACHSMBI
- .W ?60,$P(DAT,U,3),?65,$$MDY($P(DAT,U)),?72,$$MDY($P(DAT,U,2))
- PVT ;
- G END:'$D(^AUPNPRVT(DFN,11))
- S I=0
- PVT1 ;
- ;****LOOP THRU PRIVATE INSURANCE
- ;ACHS*3.1*27 REWROTE TO TEST FOR ELIG DATES
- F S I=$O(^AUPNPRVT(DFN,11,I)) G:I'?1N.N END D
- .I $G(ACHSEDOS) Q:ACHSEDOS<$P(^AUPNPRVT(DFN,11,I,0),U,6)
- .I $G(ACHSEDOS),$P(^AUPNPRVT(DFN,11,I,0),U,7)'="" Q:ACHSEDOS>($P(^(0),U,7))
- .S ACHSINS=^AUPNPRVT(DFN,11,I,0)
- .W !?ACHSTAB,$E($P(^AUTNINS($P(ACHSINS,U),0),U),1,26)
- .I $P(ACHSINS,U,8),$D(^AUPN3PPH($P(ACHSINS,U,8),0)) D
- ..S I2=$P(^AUPNPRVT(DFN,11,I,0),U,8)
- ..W ?30,$P(^AUPN3PPH(I2,0),U,4)," "
- ..I $P(^AUPN3PPH(I2,0),U,5) D
- ...S X=$P(^AUTTPIC($P(^AUPN3PPH(I2,0),U,5),0),U)
- ...W ?64-$L(X),$E(X,1,64-$X)
- .W ?65,$$MDY($P(^AUPNPRVT(DFN,11,I,0),U,6)),?72,$$MDY($P(^(0),U,7))
- ;
- ;
- END ;
- K I,I2,JJ,ACHSINS,DAT
- Q
- ;
- MDY(X) ;
- Q $E(X,4,7)_$E(X,2,3)
- ;
- ACHSRP31 ; IHS/ITSC/PMF - PRINT CHS (43 & 64) FORMS (2/2) ;
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,27**;JUN 11,2001;Build 43
- +2 ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
- +3 ;ACHS*3.1*27 11.14.17 IHS.OIT.FCJ CHANGE FOR NEW MEDICARE NUMBER
- +4 ;
- +5 IF $$PARM^ACHS(2,16)'="Y"
- WRITE !!!!
- +6 ;
- EN ;EP - From CHEF report.
- +1 IF $GET(DFN)=""
- WRITE !!,"DFN variable MUST be defined when entering this routine!!"
- QUIT
- +2 ;
- +3 WRITE !!?ACHSTAB,"Type of Coverage",?30,"Policy #",?55,"Cov. type EligDt TermDt",!?ACHSTAB,"----------------",?30,"--------",?55,"--------- ------ ------"
- +4 ;
- +5 ;LETS LOOK AT POSSIBLE MEDICARE COVERAGE
- MCR ;
- +1 IF '$DATA(^AUPNMCR(DFN))
- GOTO MCD
- +2 ;G MCD:'$P($G(^AUPNMCR(DFN,0)),U,3) ;ACHS*3.1*27 NEW NUMBER STORED IN PAT REG
- +3 ;S X=$J("",ACHSTAB)_$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U)
- +4 IF $PIECE($GET(^AUPNMCR(DFN,0),"UNDEFINED"),U,2)'=""
- Begin DoDot:1
- +5 SET X=$JUSTIFY("",ACHSTAB)_$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNMCR(DFN,0)),U,2),0)),U)
- End DoDot:1
- +6 IF '$TEST
- SET X=$JUSTIFY("",ACHSTAB)
- +7 SET X=X_$JUSTIFY("",30-$LENGTH(X))
- +8 ;ACHS*3.1*27 MODIFIED NXT SECTION FOR NEW MBI AND CHECK FOR "D" COVERAGE AND ELIG DATES
- +9 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
- +10 IF +ACHSMBI<1
- SET ACHSMBI=$PIECE(^AUPNMCR(DFN,0),U,3)
- IF $PIECE(^(0),U,4)
- IF $DATA(^AUTTMCS($PIECE(^(0),U,4),0))
- SET ACHSMBI=ACHSMBI_$PIECE(^(0),U)
- +11 ;GO THRU 'MEDICARE ELIGIBLE' FILE
- +12 SET I=0
- +13 FOR
- SET I=$ORDER(^AUPNMCR(DFN,11,I))
- IF +I=0
- QUIT
- Begin DoDot:1
- +14 IF $GET(ACHSEDOS)
- IF ACHSEDOS<$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U)
- QUIT
- +15 IF $GET(ACHSEDOS)
- IF $PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2)'=""
- IF ACHSEDOS>$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2)
- QUIT
- +16 WRITE !,X
- +17 ;COVERAGE TYPE OF "D"
- IF $PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)?1"D"
- WRITE $PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,6)
- +18 IF '$TEST
- WRITE ACHSMBI
- +19 ;'COVERAGE TYPE'
- WRITE ?60,$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)
- +20 ;'ELIG. DATE'
- WRITE ?65,$$MDY($PIECE($GET(^AUPNMCR(DFN,11,I,0)),U))
- +21 ;'ELIG. END DATE'
- WRITE ?72,$$MDY($PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2))
- End DoDot:1
- +22 ;
- +23 ;LETS LOOK AT POSSIBLE MEDICAID COVERAGE
- MCD ;
- +1 IF '$DATA(^AUPNMCD("B",DFN))
- GOTO RRE
- +2 KILL ^TMP("ACHSRP31",$JOB,"MCD")
- +3 FOR I=0:0
- SET I=$ORDER(^AUPNMCD("B",DFN,I))
- IF 'I
- QUIT
- FOR JJ=0:0
- SET JJ=$ORDER(^AUPNMCD(I,11,JJ))
- IF 'JJ
- QUIT
- Begin DoDot:1
- +4 SET ^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ)=$GET(^AUPNMCD(I,11,JJ,0))
- +5 SET $PIECE(^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ),U,4,6)=$PIECE($GET(^AUPNMCD(I,0)),U,2,4)
- End DoDot:1
- +6 ;
- +7 SET JJ=0
- SET DAT=""
- +8 FOR ACHS=1:1:4
- SET JJ=$ORDER(^TMP("ACHSRP31",$JOB,"MCD",JJ))
- IF 'JJ
- QUIT
- IF $PIECE(^TMP("ACHSRP31",$JOB,"MCD",JJ),U,6)]""
- IF $DATA(^DIC(5,$PIECE(^(JJ),U,6),0))
- SET $PIECE(^TMP("ACHSRP31",$JOB,"MCD",JJ),U,6)=$PIECE(^(0),U,2)
- +9 SET I=0
- +10 ;ACHS*3.1*27 REWROTE TO TST FOR ELIG DATES
- +11 FOR ACHS=1:1:4
- SET I=$ORDER(^TMP("ACHSRP31",$JOB,"MCD",I))
- IF 'I
- QUIT
- Begin DoDot:1
- +12 SET DAT=^TMP("ACHSRP31",$JOB,"MCD",I)
- +13 IF $GET(ACHSEDOS)
- IF ACHSEDOS<($PIECE(DAT,U))
- QUIT
- +14 IF $GET(ACHSEDOS)
- IF $PIECE(DAT,U,2)'=""
- IF ACHSEDOS>($PIECE(DAT,U,2))
- QUIT
- +15 WRITE !?ACHSTAB,$PIECE(^AUTNINS($PIECE(DAT,U,4),0),U)
- +16 WRITE ?30,$PIECE(DAT,U,5),$PIECE(DAT,U,6),?60,$PIECE(DAT,U,3),?65,$$MDY($PIECE(DAT,U)),?72,$$MDY($PIECE(DAT,U,2))
- End DoDot:1
- +17 KILL ^TMP("ACHSRP31",$JOB,"MCD")
- RRE ;
- +1 IF '$DATA(^AUPNRRE(DFN,0))
- GOTO PVT
- +2 ;ACHS*3.1*27 REWROTE TO TST FOR ELIG DATES AND PRINT MBI
- +3 ;******LOOP THRU RAILROAD ELIGIBLE FILE
- +4 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
- +5 IF +ACHSMBI<1
- Begin DoDot:1
- +6 SET ACHSMBI=""
- +7 IF $PIECE($GET(^AUPNRRE(DFN,0)),U,3)'=""
- SET ACHSMBI=$PIECE(^AUTTRRP($PIECE(^AUPNRRE(DFN,0),U,3),0),U)
- +8 ;PRNT PREFIX FOR OLD NUMBER
- SET ACHSMBI=ACHSMBI_$PIECE($GET(^AUPNRRE(DFN,0)),U,4)
- End DoDot:1
- +9 SET I=0
- +10 FOR
- SET I=$ORDER(^AUPNRRE(DFN,11,I))
- IF I'?1N.N
- QUIT
- Begin DoDot:1
- +11 SET DAT=^AUPNRRE(DFN,11,I,0)
- +12 IF $GET(ACHSEDOS)
- IF ACHSEDOS<$PIECE(DAT,U)
- QUIT
- +13 IF $GET(ACHSEDOS)
- IF $PIECE(DAT,U,2)'=""
- IF ACHSEDOS>($PIECE(DAT,U,2))
- QUIT
- +14 WRITE !?ACHSTAB
- +15 IF $PIECE($GET(^AUPNRRE(DFN,0)),U,2)'=""
- WRITE $PIECE($GET(^AUTNINS($PIECE(^AUPNRRE(DFN,0),U,2),0)),U),?30
- +16 WRITE ACHSMBI
- +17 WRITE ?60,$PIECE(DAT,U,3),?65,$$MDY($PIECE(DAT,U)),?72,$$MDY($PIECE(DAT,U,2))
- End DoDot:1
- PVT ;
- +1 IF '$DATA(^AUPNPRVT(DFN,11))
- GOTO END
- +2 SET I=0
- PVT1 ;
- +1 ;****LOOP THRU PRIVATE INSURANCE
- +2 ;ACHS*3.1*27 REWROTE TO TEST FOR ELIG DATES
- +3 FOR
- SET I=$ORDER(^AUPNPRVT(DFN,11,I))
- IF I'?1N.N
- GOTO END
- Begin DoDot:1
- +4 IF $GET(ACHSEDOS)
- IF ACHSEDOS<$PIECE(^AUPNPRVT(DFN,11,I,0),U,6)
- QUIT
- +5 IF $GET(ACHSEDOS)
- IF $PIECE(^AUPNPRVT(DFN,11,I,0),U,7)'=""
- IF ACHSEDOS>($PIECE(^(0),U,7))
- QUIT
- +6 SET ACHSINS=^AUPNPRVT(DFN,11,I,0)
- +7 WRITE !?ACHSTAB,$EXTRACT($PIECE(^AUTNINS($PIECE(ACHSINS,U),0),U),1,26)
- +8 IF $PIECE(ACHSINS,U,8)
- IF $DATA(^AUPN3PPH($PIECE(ACHSINS,U,8),0))
- Begin DoDot:2
- +9 SET I2=$PIECE(^AUPNPRVT(DFN,11,I,0),U,8)
- +10 WRITE ?30,$PIECE(^AUPN3PPH(I2,0),U,4)," "
- +11 IF $PIECE(^AUPN3PPH(I2,0),U,5)
- Begin DoDot:3
- +12 SET X=$PIECE(^AUTTPIC($PIECE(^AUPN3PPH(I2,0),U,5),0),U)
- +13 WRITE ?64-$LENGTH(X),$EXTRACT(X,1,64-$X)
- End DoDot:3
- End DoDot:2
- +14 WRITE ?65,$$MDY($PIECE(^AUPNPRVT(DFN,11,I,0),U,6)),?72,$$MDY($PIECE(^(0),U,7))
- End DoDot:1
- +15 ;
- +16 ;
- END ;
- +1 KILL I,I2,JJ,ACHSINS,DAT
- +2 QUIT
- +3 ;
- MDY(X) ;
- +1 QUIT $EXTRACT(X,4,7)_$EXTRACT(X,2,3)
- +2 ;