ACHSMD0A ; IHS/ITSC/PMF - PRINT COVERAGE ON MDOL (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(ACHSDOS) ;EP - From ACHSMD0
;W !!?ACHSTAB,"Type of Coverage",?30,"Policy #",?55,"Cov. type EligDt TermDt",!?ACHSTAB,"----------------",?30,"--------",?55,"--------- ------ ------"
N ACHSTAB,ACHSMBI
S ACHSTAB=0,ACHSMBI=""
;
MCR ;
;ACHSF*3.1*27 REWROTE FOR NEW MBI
N ACHSMBI
G:'$D(^AUPNMCR(DFN)) MCD
S X=$J("",ACHSTAB)_$P(^AUTNINS($P(^AUPNMCR(DFN,0),U,2),0),U),X=X_$J("",30-$L(X))
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)
F I=0:0 S I=$O(^AUPNMCR(DFN,11,I)) Q:+I'=I D
.I $P(^AUPNMCR(DFN,11,I,0),U,2),ACHSDOS>$P(^(0),U,2) Q
.I $P(^AUPNMCR(DFN,11,I,0),U,3)?1"D" W !,X_$P(^AUPNMCR(DFN,11,I,0),U,6)
.E W !,X_ACHSMBI
.W ?60,$P(^AUPNMCR(DFN,11,I,0),U,3),?65,$$MDY($P(^(0),U)),?72,$$MDY($P(^(0),U,2))
MCD ;
G RRE:'$D(^AUPNMCD("B",DFN))
K ^TMP("ACHSRP31",$J,"MCD")
;
;12/27/00 PMF change "j" to "jj" so SAC checker doesn't freak
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)),$P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,4,6)=$P($G(^AUPNMCD(I,0)),U,2,4)
.Q
S JJ=0
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
; F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I W !?ACHSTAB,$P(^AUTNINS($P(^TMP("ACHSRP31",$J,"MCD",I),U,4),0),U),?30,$P(^TMP("ACHSRP31",$J,"MCD",I),U,5),$P(^(I),U,6),?60,$P(^(I),U,3),?65,$$MDY($P(^(I),U)),?72,$$MDY($P(^(I),U,2))
F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
.;I $P(^(I),U,2),ACHSDOS>$P(^(I),U,2) Q ;ACHS*3.1*13 12/07/06 IHS/OIT/FCJ FX NAKED GLB REF
.I $P(^TMP("ACHSRP31",$J,"MCD",I),U,2),ACHSDOS>$P(^(I),U,2) Q ;ACHS*3.1*13 12/07/06 IHS/OIT/FCJ
.W !?ACHSTAB,$P(^AUTNINS($P(^TMP("ACHSRP31",$J,"MCD",I),U,4),0),U),?30,$P(^TMP("ACHSRP31",$J,"MCD",I),U,5),$P(^(I),U,6),?60,$P(^(I),U,3),?65,$$MDY($P(^(I),U)),?72,$$MDY($P(^(I),U,2))
K ^TMP("ACHSRP31",$J,"MCD")
RRE ;
G PVT:'$D(^AUPNRRE(DFN,0))
;ACHSF*3.1*27 REWROTE FOR NEW MBI
S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
S JJ=$O(^AUPNRRE(DFN,11,0))
I JJ F I=JJ:0 S I=$O(^AUPNRRE(DFN,11,I)) Q:+I'=I S:$P(^AUPNRRE(DFN,11,I,0),U)>$P(^AUPNRRE(DFN,11,JJ,0),U) JJ=I
I JJ D
. I $P(^AUPNRRE(DFN,11,JJ,0),U,2),ACHSDOS>$P(^(0),U,2) Q
. W !?ACHSTAB,$P(^AUTNINS($P(^AUPNRRE(DFN,0),U,2),0),U),?30
. I +ACHSMBI<1 W:$P(^AUPNRRE(DFN,0),U,3)]"" $P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U) W $P(^AUPNRRE(DFN,0),U,4)
. E W ACHSMBI
. W ?60,$P(^AUPNRRE(DFN,11,JJ,0),U,3),?65,$$MDY($P(^(0),U)),?72,$$MDY($P(^(0),U,2))
.Q
PVT ;
G END:'$D(^AUPNPRVT(DFN,11))
S I=0
PVT1 ;
S I=$O(^AUPNPRVT(DFN,11,I))
G END:'I
I $P(^AUPNPRVT(DFN,11,I,0),U,7),ACHSDOS>$P(^(0),U,7) G PVT1
;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
;W !?ACHSTAB,$E($P(^AUTNINS($P(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26),?30,$P(^AUPNPRVT(DFN,11,I,0),U,2)," "
;I $P(^AUPNPRVT(DFN,11,I,0),U,3) S X=$P(^AUTTPIC($P(^(0),U,3),0),U) W ?64-$L(X),$E(X,1,64-$X)
W !?ACHSTAB,$E($P(^AUTNINS($P(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26)
I $P(^AUPNPRVT(DFN,11,I,0),U,8),$D(^AUPN3PPH($P(^AUPNPRVT(DFN,11,I,0),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)
;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT END OF CHANGES
W ?65,$$MDY($P(^AUPNPRVT(DFN,11,I,0),U,6)),?72,$$MDY($P(^(0),U,7))
G PVT1
;
END ;
K I,JJ
Q
;
MDY(X) ;
Q $E(X,4,7)_$E(X,2,3)
;
ACHSMD0A ; IHS/ITSC/PMF - PRINT COVERAGE ON MDOL (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(ACHSDOS) ;EP - From ACHSMD0
+1 ;W !!?ACHSTAB,"Type of Coverage",?30,"Policy #",?55,"Cov. type EligDt TermDt",!?ACHSTAB,"----------------",?30,"--------",?55,"--------- ------ ------"
+2 NEW ACHSTAB,ACHSMBI
+3 SET ACHSTAB=0
SET ACHSMBI=""
+4 ;
MCR ;
+1 ;ACHSF*3.1*27 REWROTE FOR NEW MBI
+2 NEW ACHSMBI
+3 IF '$DATA(^AUPNMCR(DFN))
GOTO MCD
+4 SET X=$JUSTIFY("",ACHSTAB)_$PIECE(^AUTNINS($PIECE(^AUPNMCR(DFN,0),U,2),0),U)
SET X=X_$JUSTIFY("",30-$LENGTH(X))
+5 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+6 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)
+7 FOR I=0:0
SET I=$ORDER(^AUPNMCR(DFN,11,I))
IF +I'=I
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNMCR(DFN,11,I,0),U,2)
IF ACHSDOS>$PIECE(^(0),U,2)
QUIT
+9 IF $PIECE(^AUPNMCR(DFN,11,I,0),U,3)?1"D"
WRITE !,X_$PIECE(^AUPNMCR(DFN,11,I,0),U,6)
+10 IF '$TEST
WRITE !,X_ACHSMBI
+11 WRITE ?60,$PIECE(^AUPNMCR(DFN,11,I,0),U,3),?65,$$MDY($PIECE(^(0),U)),?72,$$MDY($PIECE(^(0),U,2))
End DoDot:1
MCD ;
+1 IF '$DATA(^AUPNMCD("B",DFN))
GOTO RRE
+2 KILL ^TMP("ACHSRP31",$JOB,"MCD")
+3 ;
+4 ;12/27/00 PMF change "j" to "jj" so SAC checker doesn't freak
+5 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
+6 SET ^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ)=$GET(^AUPNMCD(I,11,JJ,0))
SET $PIECE(^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ),U,4,6)=$PIECE($GET(^AUPNMCD(I,0)),U,2,4)
+7 QUIT
End DoDot:1
+8 SET JJ=0
+9 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)
+10 SET I=0
+11 ; F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I W !?ACHSTAB,$P(^AUTNINS($P(^TMP("ACHSRP31",$J,"MCD",I),U,4),0),U),?30,$P(^TMP("ACHSRP31",$J,"MCD",I),U,5),$P(^(I),U,6),?60,$P(^(I),U,3),?65,$$MDY($P(^(I),U)),?72,$$MDY($P(^(I),U,2))
+12 FOR ACHS=1:1:4
SET I=$ORDER(^TMP("ACHSRP31",$JOB,"MCD",I))
IF 'I
QUIT
Begin DoDot:1
+13 ;I $P(^(I),U,2),ACHSDOS>$P(^(I),U,2) Q ;ACHS*3.1*13 12/07/06 IHS/OIT/FCJ FX NAKED GLB REF
+14 ;ACHS*3.1*13 12/07/06 IHS/OIT/FCJ
IF $PIECE(^TMP("ACHSRP31",$JOB,"MCD",I),U,2)
IF ACHSDOS>$PIECE(^(I),U,2)
QUIT
+15 WRITE !?ACHSTAB,$PIECE(^AUTNINS($PIECE(^TMP("ACHSRP31",$JOB,"MCD",I),U,4),0),U),?30,$PIECE(^TMP("ACHSRP31",$JOB,"MCD",I),U,5),$PIECE(^(I),U,6),?60,$PIECE(^(I),U,3),?65,$$MDY($PIECE(^(I),U)),?72,$$MDY($PIECE(^(I),U,2))
End DoDot:1
+16 KILL ^TMP("ACHSRP31",$JOB,"MCD")
RRE ;
+1 IF '$DATA(^AUPNRRE(DFN,0))
GOTO PVT
+2 ;ACHSF*3.1*27 REWROTE FOR NEW MBI
+3 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+4 SET JJ=$ORDER(^AUPNRRE(DFN,11,0))
+5 IF JJ
FOR I=JJ:0
SET I=$ORDER(^AUPNRRE(DFN,11,I))
IF +I'=I
QUIT
IF $PIECE(^AUPNRRE(DFN,11,I,0),U)>$PIECE(^AUPNRRE(DFN,11,JJ,0),U)
SET JJ=I
+6 IF JJ
Begin DoDot:1
+7 IF $PIECE(^AUPNRRE(DFN,11,JJ,0),U,2)
IF ACHSDOS>$PIECE(^(0),U,2)
QUIT
+8 WRITE !?ACHSTAB,$PIECE(^AUTNINS($PIECE(^AUPNRRE(DFN,0),U,2),0),U),?30
+9 IF +ACHSMBI<1
IF $PIECE(^AUPNRRE(DFN,0),U,3)]""
WRITE $PIECE(^AUTTRRP($PIECE(^AUPNRRE(DFN,0),U,3),0),U)
WRITE $PIECE(^AUPNRRE(DFN,0),U,4)
+10 IF '$TEST
WRITE ACHSMBI
+11 WRITE ?60,$PIECE(^AUPNRRE(DFN,11,JJ,0),U,3),?65,$$MDY($PIECE(^(0),U)),?72,$$MDY($PIECE(^(0),U,2))
+12 QUIT
End DoDot:1
PVT ;
+1 IF '$DATA(^AUPNPRVT(DFN,11))
GOTO END
+2 SET I=0
PVT1 ;
+1 SET I=$ORDER(^AUPNPRVT(DFN,11,I))
+2 IF 'I
GOTO END
+3 IF $PIECE(^AUPNPRVT(DFN,11,I,0),U,7)
IF ACHSDOS>$PIECE(^(0),U,7)
GOTO PVT1
+4 ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
+5 ;W !?ACHSTAB,$E($P(^AUTNINS($P(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26),?30,$P(^AUPNPRVT(DFN,11,I,0),U,2)," "
+6 ;I $P(^AUPNPRVT(DFN,11,I,0),U,3) S X=$P(^AUTTPIC($P(^(0),U,3),0),U) W ?64-$L(X),$E(X,1,64-$X)
+7 WRITE !?ACHSTAB,$EXTRACT($PIECE(^AUTNINS($PIECE(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26)
+8 IF $PIECE(^AUPNPRVT(DFN,11,I,0),U,8)
IF $DATA(^AUPN3PPH($PIECE(^AUPNPRVT(DFN,11,I,0),U,8),0))
Begin DoDot:1
+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:2
+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:2
End DoDot:1
+14 ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT END OF CHANGES
+15 WRITE ?65,$$MDY($PIECE(^AUPNPRVT(DFN,11,I,0),U,6)),?72,$$MDY($PIECE(^(0),U,7))
+16 GOTO PVT1
+17 ;
END ;
+1 KILL I,JJ
+2 QUIT
+3 ;
MDY(X) ;
+1 QUIT $EXTRACT(X,4,7)_$EXTRACT(X,2,3)
+2 ;
