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

AGED51.m

Go to the documentation of this file. 
  1. AGED51 ; IHS/ASDS/EFG - PAGE 5 CONT'D ;
  1.  ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
  1.  ;
  1. EDIT ;EP
  1.  ;edit Medicaid #
  1.  S DIR(0)="9000004,.03"
  1.  S DIR("B")=$G(AG("MNUM"))
  1.  D ^DIR
  1.  K DIR
  1.  G VAR^AGED5:$D(DTOUT)!(Y="^")!(Y="^^")!(Y="/.,")!(Y="^")
  1.  I '$D(X) W *7 G VAR^AGED5
  1. EDIT0 G EDIT1:(X=$G(AG("MNUM")))
  1.  S DR=".03///"_X
  1.  S DA=AG("MCD")
  1.  S DIE="^AUPNMCD("
  1.  D ^DIE
  1. EDIT1 ;
  1.  K DIR,DFOUT,DUOUT,DQOUT,DLOUT,DTOUT
  1.  G DATES:'$D(^DD(9000004,.05)) W !!,"Enter the NAME OF THE INSURED person.",!,"(Enter SAME if the PATIENT is the primary insured person.)",!
  1.  S DIR("B")=$P(^AUPNMCD(AG("MCD"),0),U,5)
  1.  S DIR(0)="F"
  1.  D ^DIR
  1.  Q:$D(DTOUT)
  1.  S:Y="/.,"!(Y="^^") DFOUT=""
  1.  S:Y="" DLOUT=""
  1.  S:Y="^" (DUOUT,Y)=""
  1.  S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
  1.  G QUES3:$D(DQOUT),L34:$D(DLOUT)&($P(^AUPNMCD(AG("MCD"),0),U,5)]""),EDIT1:Y="" I Y="SAME" D SAME G EDIT1:$P(^AUPNMCD(AG("MCD"),0),U,5)="",DATES
  1.  S DIE("NO^")=""
  1.  S DR=".05///"_Y
  1.  S DA=AG("MCD"),DIE="^AUPNMCD("
  1.  D ^DIE
  1.  G EDIT1:$P(^AUPNMCD(AG("MCD"),0),U,5)=""
  1. L34 ;
  1.  S DIC="^AUTTRLSH("
  1.  S DIC(0)="QAZEM"
  1.  S DIC("A")="Enter PATIENT'S RELATIONSHIP to the insured: "
  1.  K DIC("B")
  1.  S AGREL=+$P(^AUPNMCD(DA,0),U,6)
  1.  I AGREL'=0,$D(^AUTTRLSH(AGREL,0)) S DIC("B")=$P(^AUTTRLSH(AGREL,0),U)
  1.  K AGREL
  1.  W !
  1.  D ^DIC
  1.  G EDIT1:$D(DUOUT),L34:+Y<1
  1.  S DA=AG("MCD")
  1.  S $P(^AUPNMCD(DA,0),U,6)=+Y
  1.  K DIC
  1. SEX W !
  1.  S DIE="^AUPNMCD("
  1.  S DA=AGELPTR
  1.  S DR=.07,DIE("NO^")=""
  1.  D ^DIE
  1. DATES D DATES1
  1.  D PCP
  1.  D CCOPY
  1. MCDNM W !
  1.  S DIE="^AUPNMCD("
  1.  S DA=AG("MCD")
  1.  S DR=2101
  1.  D ^DIE
  1.  I '$D(^AUPNMCD(AG("MCD"),21)) G MCDDB
  1.  D:$P(^AUPNMCD(AG("MCD"),21),U)]"" SETOTHER G MCDDB
  1. SETOTHER ;
  1.  Q
  1.  S DIE="^DPT("
  1.  S DA=DFN
  1.  S DR="1///"_$P(^AUPNMCD(AG("MCD"),21),U)
  1.  S DR(2,2.01)=.01
  1.  D ^DIE
  1.  Q
  1. MCDDB W !
  1.  S DIE="^AUPNMCD("
  1.  S DA=AG("MCD")
  1.  S DR=2102
  1.  D ^DIE
  1.  S DR=".11;.12"
  1.  D ^DIE
  1.  G VAR^AGED5
  1. QUES3 W !!
  1.  W "Enter the name of the person in whose name the main account is carried."
  1.  W !,"The name must be in the same format as the patient names.",!!
  1.  W "If the patient is the primary insured person, enter SAME.",!!
  1.  G EDIT1
  1. SAME S DA=AG("MCD")
  1.  S DR=".05///"_$P(^DPT(DFN,0),U)
  1.  S DIE="^AUPNMCD("
  1.  D ^DIE
  1.  S DR=".07///"_$P(^DPT(DFN,0),U,2)_";.06///SELF"
  1.  D ^DIE
  1.  Q
  1. DATES1 ;
  1.  KILL DIE("NO^")
  1.  NEW AGBILL,AGDA,DA,DIC,DIE,DR
  1.  S DIC="^AUPNMCD("_AG("MCD")_",11,"
  1.  S DIC(0)="AEL"
  1.  S DIC("A")="Select ELIG. DATE: "
  1.  S DA(1)=AG("MCD")
  1.  I '$D(^AUPNMCD(AG("MCD"),11)) S DIC("P")=$P(^DD(9000004,1101,0),U,2)
  1.  E  I $P($G(^AUPNMCD(AG("MCD"),11,0)),U,4) S Y=$P(^AUPNMCD(AG("MCD"),11,$O(^AUPNMCD(AG("MCD"),11,0)),0),U,1) I Y D DD^%DT S DIC("B")=Y
  1.  D ^DIC
  1.  Q:+Y<1
  1.  S AGDA=+Y
  1.  S AGBILL=$$USED(DFN,$P(^AUPNMCD(AG("MCD"),0),U,2),7,+Y,AG("MCD"))
  1.  I $L(AGBILL) S X="IORVON;IORVOFF" D ENDR^%ZISS,HELP^XBHELP("USED","AGED51"),KILL^%ZISS Q:'$$DIR^XBDIR("Y","Proceed with edit of Date Record","N")
  1.  W !
  1.  S DA(1)=AG("MCD")
  1.  S DIE="^AUPNMCD("_DA(1)_",11,"
  1.  S DR=".01:.03",DA=AGDA
  1.  D ^DIE,UPDATE^AGED5
  1.  Q
  1. PCP ;
  1.  S DA=AG("MCD")
  1.  S DR=.14
  1.  S DIE="^AUPNMCD("
  1.  D ^DIE
  1.  Q
  1. CCOPY ;
  1.  S DA=AG("MCD")
  1.  S DR=.15
  1.  S DIE="^AUPNMCD("
  1.  D ^DIE
  1.  I X["Y" D
  1.  .S DR=.16
  1.  .S DIE="^AUPNMCD("
  1.  .D ^DIE
  1.  I X["N" D
  1.  .S DR=".16////@"
  1.  .S DIE="^AUPNMCD("
  1.  .D ^DIE
  1.  Q
  1. USED(DFN,AGINSPTR,AGP,AGDA,AGMCDDA) ;EP - Is this Eligibility date record used in a 3P Bill or Claim?
  1.  ;;@;*7
  1.  ;;@;IORVON
  1.  ;;WARNING :
  1.  ;;@;IORVOFF
  1.  ;;          You have selected an Eligibility Date Record that is used
  1.  ;;          by
  1.  ;;@;AGBILL
  1.  ;;          in 3PB. Modifying or deleting this Eligibility
  1.  ;;          Date Record will degrade the integrity of your database
  1.  ;;          and could adversely effect revenue recovery through 3PB!!
  1.  ;;###
  1.  ;
  1.  NEW AGBILL,AGDUZ2,AGUSED,AG13,Y
  1.  S (AGBILL,AGDUZ2,AGUSED)=0
  1.  ;Check all Pt's bills.
  1.  F  S AGDUZ2=$O(^ABMDBILL(AGDUZ2)) Q:'AGDUZ2  D  Q:AGUSED
  1.  . F  S AGBILL=$O(^ABMDBILL(AGDUZ2,"D",DFN,AGBILL)) Q:'AGBILL  D  Q:AGUSED
  1.  .. I $P(^ABMDBILL(AGDUZ2,AGBILL,0),U,4)="X" Q  ;Cancelled.
  1.  .. S AG13=0
  1.  .. F  S AG13=$O(^ABMDBILL(AGDUZ2,AGBILL,13,AG13)) Q:'AG13  D  Q:AGUSED
  1.  ... ;Same multiple?
  1.  ... Q:'($P(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0),U,AGP)=AGDA)
  1.  ... ;If MCD, same IEN?
  1.  ... I AGP=7,'($P(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0),U,6)=AGMCDDA) Q
  1.  ... S AGUSED=$P(^ABMDBILL(AGDUZ2,AGBILL,0),U)_" ("_$P(^DIC(4,AGDUZ2,0),U)_")" ; Bill number (Site).
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I AGUSED Q "Bill # "_AGUSED
  1.  ;
  1.  S (AGBILL,AGDUZ2,AGUSED)=0
  1.  ;Check all Pt's claims.
  1.  F  S AGDUZ2=$O(^ABMDCLM(AGDUZ2)) Q:'AGDUZ2  D  Q:AGUSED
  1.  . F  S AGBILL=$O(^ABMDCLM(AGDUZ2,"B",DFN,AGBILL)) Q:'AGBILL  D  Q:AGUSED
  1.  .. S AG13=0
  1.  .. F  S AG13=$O(^ABMDCLM(AGDUZ2,AGBILL,13,AG13)) Q:'AG13  D  Q:AGUSED
  1.  ... ;Same multiple?
  1.  ... Q:'($P(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0),U,AGP)=AGDA)
  1.  ... ;If MCD, same IEN?
  1.  ... I AGP=7,'($P(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0),U,6)=AGMCDDA) Q
  1.  ... S AGUSED=AGBILL_" ("_$P(^DIC(4,AGDUZ2,0),U)_")" ;Claim number (Site).
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I AGUSED Q "Claim # "_AGUSED
  1.  Q ""
  1.  ;
  1.  ; MEDICARE MULTIPLE (NJ6,0), [0;4]
  1.  ; RAILROAD MULTIPLE (NJ6,0), [0;5]
  1.  ; MEDICAID ELIG POINTER (*P9000004'), [0;6]
  1.  ; MEDICAID MULTIPLE (NJ4,0), [0;7]
  1.  ; PRIVATE INSURANCE MULTIPLE (NJ6,0), [0;8]