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

AG4.m

Go to the documentation of this file. 
  1. AG4 ; IHS/ASDS/EFG - ENTER MEDICARE DATA ;  
  1.  ;;7.1;PATIENT REGISTRATION;**1,2,11,13**;AUG 25, 2005;Build 1
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
  1.  ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
  1.  ;
  1. L1 S AG("LT")=$S($D(^AUPNMCR(DFN,0)):"YES",1:"NO")
  1.  W !!,"Does this patient have MEDICARE COVERAGE? (Y/N) ",AG("LT"),"// "
  1.  D READ^AG
  1.  S AG("LT")=$S($E(Y)="Y":"YES",1:"NO")
  1.  Q:$D(DTOUT)!$D(DFOUT)
  1.  ;TESTING USE OF EDIT SCREEN FOR ADDING INSURANCE TO NEW PATIENT 5/13/2005
  1.  I $G(^AGFAC(DUZ(2),"NEWADDINS")) I AG("LT")="YES" S AGPAT=$P($G(^DPT(DFN,0)),U) S AGXTERN=1 D EN^AGED4("") K AGXTERN,DUOUT G:$G(NEWENTRY)=0 ^AG5 G L1
  1.  I $G(^AGFAC(DUZ(2),"NEWADDINS")),$D(DUOUT) G DUOUT^AG3
  1.  I $G(^AGFAC(DUZ(2),"NEWADDINS")),($G(AG("LT"))="NO") G ^AG5
  1.  ;TESTING
  1.  G L2:Y["Y"
  1.  G END1:Y["N"!($D(DLOUT)&(AG("LT")="NO"))
  1.  G L2:$D(DLOUT)&(AG("LT")="YES") I $D(DUOUT) G DUOUT^AG3
  1.  D YN^AG G L1
  1. ADDNEW ;EP - ADD NEW MEDICARE CLIENT.
  1. L2 W !
  1.  ;BEGIN AG*7.1*2 IM20637
  1.  I $$ISMINOR^AGUTILS(DFN) D  G:'Y END1
  1.  .K DIR
  1.  .S DIR(0)="Y"
  1.  .S DIR("A")="A MINOR CANNOT BE THE POLICY HOLDER FOR MEDICARE ..DO YOU WISH TO ADD ENTRY?//"  ;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20637
  1.  .S DIR("B")="N"
  1.  .D ^DIR
  1.  ;END AG*7.1*2 IM20637
  1.  S NEWENTRY=1  ;IHS/SD/TPF 12/6/2005 AG*7.1*1
  1.  I $G(AGTYPE)="MD" G ADDCOV  ;IHS/SD/TPF 12/6/2005 AG*7.1*1 ITEM 2
  1.  K DIE,DIC,DR,DIR
  1.  S DIE="^AUPNPAT("
  1.  ;REQUIRE MEDICARE REL DATE
  1.  S DR=".04R",DA=DFN
  1.  D ^DIE Q:$D(Y)&$D(AG("EDIT"))  G L1:$D(Y) G L3:$D(^AUPNMCR(DFN,0))
  1.  S AG("INS")=$O(^AUTNINS("B","MEDICARE",""))
  1.  K DIC,DIE,DR,DIR,D0,DD
  1.  S DIC="^AUPNMCR("
  1.  S DIC(0)="L"
  1.  S X="`"_DFN
  1.  D ^DIC
  1.  Q:+Y<0
  1.  S DA=+Y
  1.  S DIE="^AUPNMCR(",DA=DFN,DR=".02///"_AG("INS")
  1.  D ^DIE
  1. L3 ;
  1.  ;W !!,"Enter the MEDICARE INSURANCE NUMBER (""suffix"" will be asked seperately)."
  1. L4 ;REQUIRE MCR NUMBER
  1.  ;S DR=".03R",DA=DFN
  1.  ;S DIE="^AUPNMCR("
  1.  ;D ^DIE
  1.  ;I $D(Y) G L2
  1. L5 ;
  1.  ;S DIE="^AUPNMCR("
  1.  ;REQUIRE SUFFIX
  1.  ;S DA=DFN,DR=".04R"
  1.  ;D ^DIE
  1.  ;I $D(Y) G L4
  1.  D EDITMCR^AGUTL(DFN,1)  ;IHS/OIT/NKD AG*7.1*13
  1.  S DIE="^AUPNMCR(",DA=DFN
  1.  S ADDCHK=""
  1.  ;REQUIRE MCR NAME
  1.  S DR="2101R"
  1.  I $G(NEWENTRY)!($P($G(^AUPNMCR(DA,21)),U)="") S DR=DR_"//"_$P($G(^DPT(DFN,0)),U)
  1.  D ^DIE
  1.  I '$D(^AUPNMCR(DFN,21)) G L6
  1. L6 ;REQUIRE MCR DOB
  1.  S DR="2102R"
  1.  I $G(NEWENTRY)!($P($G(^AUPNMCR(DA,21)),U,2)="") N AGDOB,Y S Y=$P($G(^DPT(DFN,0)),U,3) X ^DD("DD") S AGDOB=Y S DR=DR_"//"_AGDOB K Y
  1.  D ^DIE
  1.  K AGDOB
  1. QMB S DR=.08,DA=DFN
  1.  S DIE="^AUPNMCR("
  1.  D ^DIE
  1. IMPMSG ;
  1.  S DIC(0)="LMQE"
  1.  S DA(1)=DFN
  1.  S DIC="^AUPNMCR("_DA(1)_",12,"
  1.  D ^DIC
  1.  ;
  1. PCP S DR=.14,DA=DFN
  1.  S DIE="^AUPNMCR("
  1.  D ^DIE
  1. CC S DR=.15,DA=DFN
  1.  S DIE="^AUPNMCR("
  1.  D ^DIE
  1. CCD S DR=.16,DA=DFN
  1.  S DIE="^AUPNMCR("
  1.  D ^DIE
  1. ADDCOV ;EP - ADD NEW COVERAGE.
  1. L7 W !!,"Enter the ELIGIBILITY DATE: "
  1.  D:'$D(AG("EDIT")) DFLT1
  1.  D READ^AG
  1.  I Y="" W !,"MEDICARE ELIGIBILITY DATE REQUIRED!" H 2 G L7
  1.  Q:$D(DUOUT)&$D(AG("EDIT"))  G END1:$D(DTOUT)!$D(DFOUT)!($D(DLOUT)&'$D(AG("LT1"))),L5:$D(DUOUT),L8:$D(DLOUT)
  1.  S:$D(DQOUT) Y="?"
  1.  S X=Y,%DT="EX"
  1.  D ^%DT
  1.  G L7:Y<2600000!(Y>(DT+20000))
  1.  I Y>DT W *7,!!,"SURE ABOUT THE FUTURE START DATE" S %=2 D YN^DICN G:%=2 L7
  1.  S AG("DT")=Y
  1.  K AG("COV"),COVTYP  ;IHS/OIT/NKD AG*7.1*13
  1.  ;L8 I $G(AGTYPE)="MD" S AG("COV")="D" K AG("MORE") G L9  ;IHS/SD/TPF 12/2/2005 AG*7.1*1
  1. L8  ;I $G(AGTYPE)="MD" S AG("COV")="D" K AG("MORE") G L9  ;IHS/SD/TPF 12/2/2005 AG*7.1*1  ;IHS/OIT/NKD AG*7.1*13
  1.  ;W !!,"Type of COVERAGE (A, B): "
  1.  W !!,"Type of COVERAGE (A, B, D): "
  1.  D:'$D(AG("EDIT")) DFLT2
  1.  D READ^AG
  1.  I Y="D",$$NOPARTAB^AGED4(DFN) W !,"PATIENT MUST HAVE MEDICARE PART A OR B BEFORE BEING ELIGIBLE FOR PART D!" G L8  ;AG*7.1*1 ITEM 2
  1.  ;I Y="D",(AGELP("INS")=2) W !!,"DO NOT ADD PART D COVERAGE TO A MEDICARE INSURER ENTRY",!,"REFER TO PATCH 1 ADDENDUM IN HOW TO SET UP PART D INSURERS",! G L8  ;IHS/SD/TPF 4/25/2006 AG*7.1*2 IM20523
  1.  ;I Y="D",($P($G(^AUTNINS(AGELP("INS"),2)),U)'="MD") W !!,"CAN NOT ADD PART D COVERAGE TO A NON MEDICARE PART D INSURER",!,"REFER TO PATCH 1 ADDENDUM IN HOW TO SET UP PART D INSURERS",! G L8
  1.  ;COVERAGE TYPE IS REQUIRED
  1.  ;I Y="" W !,"Enter either ""A"" or ""B""." G L8
  1.  I Y="" W !,"Enter either ""A"" or ""B"" or ""D""." G L8
  1.  G END1:$D(DTOUT)!$D(DFOUT)!($D(DLOUT)&'$D(AG("LT2"))),L7:$D(DUOUT),L9:$D(DLOUT)
  1.  ;I $D(DQOUT)!((Y'="A")&(Y'="B")) W !,"Enter either ""A"" or ""B""." G L8
  1.  I $D(DQOUT)!((Y'="A")&(Y'="B")&(Y'="D")) W !,"Enter either ""A"" or ""B"" or ""D""." G L8
  1.  ;I $D(DQOUT)!((Y'="A")&(Y'="B")) D  H 3 G L8  ;IHS/SD/TPF 12/2/2005 AG*7.1*1
  1.  ;.I Y'="D" W !,"Enter either ""A"" or ""B""." Q
  1.  ;.W !,"You cannot Enter a new Part D on this page."
  1.  ;.W !,"Go to the Summary page and choose a Medicare Part D type of insurer"
  1.  S AG("COV")=Y
  1.  K AG("MORE")
  1. L9 S DIE="^AUPNMCR("
  1.  ;IHS/SD/TPF 12/7/05 UNREPORTED BUG FIX PER ADRIAN (updated) COLUMN ON DISPLAY HAS NO DATE
  1.  S DR=".07///^S X=DT"
  1.  D ^DIE
  1.  ;END
  1.  ;LINE BELOW ALLOWS ENTRY OF SAME DATE EVEN THOUGH THIS FIELD IS DINUMED
  1.  ;THIS IS SO MEDICARE PART A AND B CAN BE ENTERED UNDER THE SAME DATE
  1.  S DR="1101///"_$C(34)_AG("DT")_$C(34)
  1.  S DR(2,9000003.11)=".03///"_AG("COV")
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 - STUFF PT SEX INTO ELIGIBLE SEX FIELD - START NEW CODE
  1.  N AGSEX
  1.  S AGSEX=$$GET1^DIQ(2,DFN,.02,"I")
  1.  S DR(2,9000003.11)=DR(2,9000003.11)_";.08////^S X=AGSEX"
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 - END NEW CODE
  1.  S DA=DFN
  1.  D ^DIE
  1.  ;BEGIN NEW CODE IHS/SD/TPF 12/2/2005 AG*7.1*1 ITEM 1
  1.  ;S DIE("NO^")="BACK"
  1.  I $G(AG("COV"))="D" D ASKPARTD(DFN,D1) S NEWENTRY=0 D EN^AGED4PD(COMPIEN) K AG("MORE") Q:$D(AG("EDIT"))  ;AG*7.1*2 REPORTED DURING ALPHA 11/9/2006 AG("EDIT") SHOULD BE DEFINED ONLY WHEN EDITING A PAT.
  1.  ;E  D ^DIE
  1.  ;END NEW CODE
  1.  I $G(GOL8) G L8  ;IHS/SD/TPF 12/2/2005 AG*7.1*1 ITEM 1
  1.  K DIE,DIC,DR,DA
  1. END Q:$D(AG("EDIT"))
  1.  D MORE
  1.  G ADDCOV:$D(AG("MORE")) K AG
  1.  G ^AG5
  1. END1 G END:'$D(^AUPNMCR(DFN,0))!$D(AG("EDIT"))
  1.  S DA=DFN
  1.  S DIE="^AUPNMCR("
  1.  S DR=".01///@"
  1.  D ^DIE
  1.  G END
  1. DUOUT ;EP
  1.  G L1
  1. DFLT1 K AG("LT1")
  1.  Q:'$D(^AUPNMCR(DFN,11,1,0))
  1.  S DIC=9000003.11
  1.  ;REQUIRE ELIG BEGIN DATE
  1.  S DR=".01R",DA=DFN,AG("DRENT")=1
  1.  D ^AGDICLK
  1.  Q:$D(AG("LKERR"))
  1.  S AG("LT1")=AG("LKPRINT")
  1.  S AG("DT")=AG("LKDATA")
  1.  W AG("LKPRINT"),"// "
  1.  Q
  1. DFLT2 K AG("LT2")
  1.  Q:'$D(^AUPNMCR(DFN,11,1,0))
  1.  S (AG("LT2"),AG("COV"))=$P(^AUPNMCR(DFN,11,1,0),U,3)
  1.  Q:AG("LT2")=""
  1.  W AG("LT2"),"// "
  1.  Q
  1. MORE K AG("MORE")
  1.  Q:'$D(^AUPNMCR(DFN,11,0))
  1.  W !!,"Do you wish to ADD ANOTHER COVERAGE TYPE? (Y/N) NO// "
  1.  D READ^AG
  1.  Q:$D(DTOUT)!$D(DFOUT)!$D(DLOUT)!(Y["N")
  1.  G MORE1:Y["Y"
  1.  D YN^AG
  1.  G MORE
  1. MORE1 S AG("MORE")=""
  1.  Q
  1. ASKPARTD(DFN,D1) ;ASK PART D FIELDS
  1.  K DIC,DIE,DR,DA
  1.  S GOL8=0
  1.  S DA=D1
  1.  S DA(1)=DFN
  1.  S DIE="^AUPNMCR("_DA(1)_",11,"
  1. F04 ;EP
  1.  S COMPIEN=DA(1)_",11,"_DA_",0"
  1.  ;I $G(AGELP("INS"))'="" S DR=".04R//^S X=$P(^AUTNINS($G(AGELP(""INS"")),0),U)"
  1.  I $G(AGELP("INS"))'="",($G(AGELP("INS"))'=2) S DR=".04R//^S X=$P(^AUTNINS($G(AGELP(""INS"")),0),U)"
  1.  E  S DR=".04R"
  1.  D ^DIE
  1.  I $D(Y) S GOL8=1 Q
  1. F05 ;EP
  1.  S DR=".05R//^S X=$P($G(^AUPNMCR(DA(1),21)),U)"
  1.  D ^DIE
  1.  I $D(Y) G F04
  1. F06 ;EP
  1.  K DR
  1.  ;S DR=".06R//^S X=$P($G(^AUPNMCR(DA(1),0)),U,3)"
  1.  S DR=".06R//"_$$GETMCR^AGUTL(DFN)  ;IHS/OIT/NKD AG*7.1*13
  1.  D ^DIE
  1.  I $D(Y) G F05
  1. F07 ;EP
  1.  S DR=".07"
  1.  D ^DIE
  1.  I $D(Y) G F06
  1. F08 ;EP
  1.  S DR=".08R//^S X=$P($G(^DPT(DA(1),0)),U,2)"
  1.  D ^DIE
  1.  I $D(Y) G F07
  1. F09 ;EP
  1.  S DR=".09R//^S X=$P($G(^DPT(DA(1),0)),U,3)"
  1.  D ^DIE
  1.  I $D(Y) G F08
  1. F11 ;EP
  1.  S DR=".11"
  1.  D ^DIE
  1.  I $D(Y) G F09
  1. F13 ;EP
  1.  S DR=".13R"
  1.  D ^DIE
  1.  I $D(Y) G F11
  1.  Q