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 ;
