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

ACHSMD0A.m

Go to the documentation of this file. 
  1. ACHSMD0A ; IHS/ITSC/PMF - PRINT COVERAGE ON MDOL (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(ACHSDOS) ;EP - From ACHSMD0
  1.  ;W !!?ACHSTAB,"Type of Coverage",?30,"Policy #",?55,"Cov. type EligDt TermDt",!?ACHSTAB,"----------------",?30,"--------",?55,"--------- ------ ------"
  1.  N ACHSTAB,ACHSMBI
  1.  S ACHSTAB=0,ACHSMBI=""
  1.  ;
  1. MCR ;
  1.  ;ACHSF*3.1*27 REWROTE FOR NEW MBI
  1.  N ACHSMBI
  1.  G:'$D(^AUPNMCR(DFN)) MCD
  1.  S X=$J("",ACHSTAB)_$P(^AUTNINS($P(^AUPNMCR(DFN,0),U,2),0),U),X=X_$J("",30-$L(X))
  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.  F I=0:0 S I=$O(^AUPNMCR(DFN,11,I)) Q:+I'=I  D
  1.  .I $P(^AUPNMCR(DFN,11,I,0),U,2),ACHSDOS>$P(^(0),U,2) Q
  1.  .I $P(^AUPNMCR(DFN,11,I,0),U,3)?1"D" W !,X_$P(^AUPNMCR(DFN,11,I,0),U,6)
  1.  .E  W !,X_ACHSMBI
  1.  .W ?60,$P(^AUPNMCR(DFN,11,I,0),U,3),?65,$$MDY($P(^(0),U)),?72,$$MDY($P(^(0),U,2))
  1. MCD ;
  1.  G RRE:'$D(^AUPNMCD("B",DFN))
  1.  K ^TMP("ACHSRP31",$J,"MCD")
  1.  ;
  1.  ;12/27/00 PMF  change "j" to "jj" so SAC checker doesn't freak
  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)),$P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,4,6)=$P($G(^AUPNMCD(I,0)),U,2,4)
  1.  .Q
  1.  S JJ=0
  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.  ; 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))
  1.  F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I  D
  1.  .;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
  1.  .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
  1.  .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))
  1.  K ^TMP("ACHSRP31",$J,"MCD")
  1. RRE ;
  1.  G PVT:'$D(^AUPNRRE(DFN,0))
  1.  ;ACHSF*3.1*27 REWROTE FOR NEW MBI
  1.  S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
  1.  S JJ=$O(^AUPNRRE(DFN,11,0))
  1.  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
  1.  I JJ D
  1.  . I $P(^AUPNRRE(DFN,11,JJ,0),U,2),ACHSDOS>$P(^(0),U,2) Q
  1.  . W !?ACHSTAB,$P(^AUTNINS($P(^AUPNRRE(DFN,0),U,2),0),U),?30
  1.  . 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)
  1.  . E  W ACHSMBI
  1.  . W ?60,$P(^AUPNRRE(DFN,11,JJ,0),U,3),?65,$$MDY($P(^(0),U)),?72,$$MDY($P(^(0),U,2))
  1.  .Q
  1. PVT ;
  1.  G END:'$D(^AUPNPRVT(DFN,11))
  1.  S I=0
  1. PVT1 ;
  1.  S I=$O(^AUPNPRVT(DFN,11,I))
  1.  G END:'I
  1.  I $P(^AUPNPRVT(DFN,11,I,0),U,7),ACHSDOS>$P(^(0),U,7) G PVT1
  1.  ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
  1.  ;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)," "
  1.  ;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)
  1.  W !?ACHSTAB,$E($P(^AUTNINS($P(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26)
  1.  I $P(^AUPNPRVT(DFN,11,I,0),U,8),$D(^AUPN3PPH($P(^AUPNPRVT(DFN,11,I,0),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.  ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT END OF CHANGES
  1.  W ?65,$$MDY($P(^AUPNPRVT(DFN,11,I,0),U,6)),?72,$$MDY($P(^(0),U,7))
  1.  G PVT1
  1.  ;
  1. END ;
  1.  K I,JJ
  1.  Q
  1.  ;
  1. MDY(X) ;
  1.  Q $E(X,4,7)_$E(X,2,3)
  1.  ;