Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSRP31

ACHSRP31.m

Go to the documentation of this file.
  1. 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
  1. ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
  1. ;ACHS*3.1*27 11.14.17 IHS.OIT.FCJ CHANGE FOR NEW MEDICARE NUMBER
  1. ;
  1. I $$PARM^ACHS(2,16)'="Y" W !!!!
  1. ;
  1. EN ;EP - From CHEF report.
  1. I $G(DFN)="" W !!,"DFN variable MUST be defined when entering this routine!!" Q
  1. ;
  1. W !!?ACHSTAB,"Type of Coverage",?30,"Policy #",?55,"Cov. type EligDt TermDt",!?ACHSTAB,"----------------",?30,"--------",?55,"--------- ------ ------"
  1. ;
  1. ;LETS LOOK AT POSSIBLE MEDICARE COVERAGE
  1. MCR ;
  1. G:'$D(^AUPNMCR(DFN)) MCD
  1. ;G MCD:'$P($G(^AUPNMCR(DFN,0)),U,3) ;ACHS*3.1*27 NEW NUMBER STORED IN PAT REG
  1. ;S X=$J("",ACHSTAB)_$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U)
  1. I $P($G(^AUPNMCR(DFN,0),"UNDEFINED"),U,2)'="" D
  1. .S X=$J("",ACHSTAB)_$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U)
  1. E S X=$J("",ACHSTAB)
  1. S X=X_$J("",30-$L(X))
  1. ;ACHS*3.1*27 MODIFIED NXT SECTION FOR NEW MBI AND CHECK FOR "D" COVERAGE AND ELIG DATES
  1. S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
  1. 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)
  1. ;GO THRU 'MEDICARE ELIGIBLE' FILE
  1. S I=0
  1. F S I=$O(^AUPNMCR(DFN,11,I)) Q:+I=0 D
  1. .I $G(ACHSEDOS) Q:ACHSEDOS<$P($G(^AUPNMCR(DFN,11,I,0)),U)
  1. .I $G(ACHSEDOS),$P($G(^AUPNMCR(DFN,11,I,0)),U,2)'="" Q:ACHSEDOS>$P($G(^AUPNMCR(DFN,11,I,0)),U,2)
  1. .W !,X
  1. .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"
  1. .E W ACHSMBI
  1. .W ?60,$P($G(^AUPNMCR(DFN,11,I,0)),U,3) ;'COVERAGE TYPE'
  1. .W ?65,$$MDY($P($G(^AUPNMCR(DFN,11,I,0)),U)) ;'ELIG. DATE'
  1. .W ?72,$$MDY($P($G(^AUPNMCR(DFN,11,I,0)),U,2)) ;'ELIG. END DATE'
  1. ;
  1. ;LETS LOOK AT POSSIBLE MEDICAID COVERAGE
  1. MCD ;
  1. G RRE:'$D(^AUPNMCD("B",DFN))
  1. K ^TMP("ACHSRP31",$J,"MCD")
  1. 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
  1. .S ^TMP("ACHSRP31",$J,"MCD",9999999-JJ)=$G(^AUPNMCD(I,11,JJ,0))
  1. .S $P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,4,6)=$P($G(^AUPNMCD(I,0)),U,2,4)
  1. ;
  1. S JJ=0,DAT=""
  1. 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)
  1. S I=0
  1. ;ACHS*3.1*27 REWROTE TO TST FOR ELIG DATES
  1. F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
  1. .S DAT=^TMP("ACHSRP31",$J,"MCD",I)
  1. .I $G(ACHSEDOS) Q:ACHSEDOS<($P(DAT,U))
  1. .I $G(ACHSEDOS),$P(DAT,U,2)'="" Q:ACHSEDOS>($P(DAT,U,2))
  1. .W !?ACHSTAB,$P(^AUTNINS($P(DAT,U,4),0),U)
  1. .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))
  1. K ^TMP("ACHSRP31",$J,"MCD")
  1. RRE ;
  1. G PVT:'$D(^AUPNRRE(DFN,0))
  1. ;ACHS*3.1*27 REWROTE TO TST FOR ELIG DATES AND PRINT MBI
  1. ;******LOOP THRU RAILROAD ELIGIBLE FILE
  1. S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
  1. I +ACHSMBI<1 D
  1. .S ACHSMBI=""
  1. .S:$P($G(^AUPNRRE(DFN,0)),U,3)'="" ACHSMBI=$P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U)
  1. .S ACHSMBI=ACHSMBI_$P($G(^AUPNRRE(DFN,0)),U,4) ;PRNT PREFIX FOR OLD NUMBER
  1. S I=0
  1. F S I=$O(^AUPNRRE(DFN,11,I)) Q:I'?1N.N D
  1. .S DAT=^AUPNRRE(DFN,11,I,0)
  1. .I $G(ACHSEDOS) Q:ACHSEDOS<$P(DAT,U)
  1. .I $G(ACHSEDOS),$P(DAT,U,2)'="" Q:ACHSEDOS>($P(DAT,U,2))
  1. .W !?ACHSTAB
  1. .W:$P($G(^AUPNRRE(DFN,0)),U,2)'="" $P($G(^AUTNINS($P(^AUPNRRE(DFN,0),U,2),0)),U),?30
  1. .W ACHSMBI
  1. .W ?60,$P(DAT,U,3),?65,$$MDY($P(DAT,U)),?72,$$MDY($P(DAT,U,2))
  1. PVT ;
  1. G END:'$D(^AUPNPRVT(DFN,11))
  1. S I=0
  1. PVT1 ;
  1. ;****LOOP THRU PRIVATE INSURANCE
  1. ;ACHS*3.1*27 REWROTE TO TEST FOR ELIG DATES
  1. F S I=$O(^AUPNPRVT(DFN,11,I)) G:I'?1N.N END D
  1. .I $G(ACHSEDOS) Q:ACHSEDOS<$P(^AUPNPRVT(DFN,11,I,0),U,6)
  1. .I $G(ACHSEDOS),$P(^AUPNPRVT(DFN,11,I,0),U,7)'="" Q:ACHSEDOS>($P(^(0),U,7))
  1. .S ACHSINS=^AUPNPRVT(DFN,11,I,0)
  1. .W !?ACHSTAB,$E($P(^AUTNINS($P(ACHSINS,U),0),U),1,26)
  1. .I $P(ACHSINS,U,8),$D(^AUPN3PPH($P(ACHSINS,U,8),0)) D
  1. ..S I2=$P(^AUPNPRVT(DFN,11,I,0),U,8)
  1. ..W ?30,$P(^AUPN3PPH(I2,0),U,4)," "
  1. ..I $P(^AUPN3PPH(I2,0),U,5) D
  1. ...S X=$P(^AUTTPIC($P(^AUPN3PPH(I2,0),U,5),0),U)
  1. ...W ?64-$L(X),$E(X,1,64-$X)
  1. .W ?65,$$MDY($P(^AUPNPRVT(DFN,11,I,0),U,6)),?72,$$MDY($P(^(0),U,7))
  1. ;
  1. ;
  1. END ;
  1. K I,I2,JJ,ACHSINS,DAT
  1. Q
  1. ;
  1. MDY(X) ;
  1. Q $E(X,4,7)_$E(X,2,3)
  1. ;