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

AGED42.m

Go to the documentation of this file. 
  1. AGED42 ; IHS/ASDS/EFG - EDIT - PAGE 4 NEW MEDICARE SCREEN - PG2 ;
  1.  ;;7.1;PATIENT REGISTRATION;**1,2,10**;AUG 25, 2005;Build 7
  1.  ;
  1. EN(WD0,WD1,NEWENTRY,AGSELECT) ;EP -
  1.  ;IF ITS A NEW ENTRY THEN DISPLAY THE SCREEN, DISPLAY MESSAGE, AUTO-
  1.  ;MATICALLY ENTER A NEW PATIENT RECORD THEN ASK FOR THE DATE
  1.  N MCRPTR
  1.  S MCRPTR=$P($G(AGSELECT),U,2)  ;IF AGSELECT THEN SELECTION WAS MADE ON SUMMARY PAGE
  1.  S:MCRPTR="" MCRPTR=$O(^AUTNINS("B","MEDICARE",""))  ;OTHERWISE DEFAULT TO MEDICARE
  1.  I NEWENTRY D
  1.  .D DRAW,WMSG,NEWENTRY I +$G(Y)<0 D CLEANZER(WD0) W !,"New entry not made" H 3 D END Q
  1.  .D DTWC I +$G(Y)<0 D CLEANZER(WD0) W !,"New entry not made" H 3 D END Q
  1.  .S COMPIEN=WD0_","_WD1
  1.  .;S AGSELECT=$$UPDTSEL^AGUTILS("FINDMCR",.AGINS,COMPIEN)
  1.  .S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGELP("INS"))  ;AG*7.1*1 IM18549 ERROR IN ERROR MSG UPDATE
  1.  .S NEWENTRY=0
  1. VAR D DRAW
  1.  I $D(AGSEENLY) K DIR S DIR(0)="E",DIR("A")="Press return" D ^DIR Q
  1.  W !,AGLINE("EQ")
  1.  ;PROMPT FOR MSP UPDATE
  1.  I MSPALERT D
  1.  .W !,"AN MSP MUST BE DONE EVERY 90 DAYS! ENTER ""A"" TO ADD ONE NOW"
  1.  .W !
  1.  K DIR
  1.  S DIR("?")="Enter your choice now."
  1.  S DIR("?",1)="You may enter the item number of the field you wish to edit,"
  1.  S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
  1.  S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
  1.  S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
  1.  S DIR("A")="Press return to return to Page 4"
  1.  D READ^AGED1
  1.  I Y?1.N,(Y'="") W !,"EDITING OF COVERAGE TYPE PART A AND PART B MUST BE",!,"DONE THROUGH TABLE MAINTENANCE!" H 2 G VAR
  1.  G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
  1.  Q:$D(DFOUT)!$D(DTOUT)
  1.  I $D(DQOUT)!(+Y<1)!(+Y>$G(AG("N")))&(Y'="A") W !!,"You must enter a number from 1 to ",$G(AG("N")) H 2 G VAR
  1.  I Y["A" D ADDMSP G VAR
  1.  G VAR:$G(AG("C"))=""
  1.  S AGY=Y
  1.  F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N"))  D @($P(AG("C"),",",AG("SEL")))
  1.  S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2))  ;AG*7.1*1 IM18549 ERROR IN ERROR MSG UPDATE
  1.  D UPDATE1^AGED(DUZ(2),DFN,3,"")
  1.  K AGI,AGY
  1.  G VAR
  1. CLEAN(WD0) ;CLEAN EMPTY RECORD. IF NO ELIGIBILITY DATES RECORD IS
  1.  ;MEANINGLESS
  1.  I $G(WD1)="" D CLEANZER(WD0)
  1.  Q
  1. CLEANZER(WD0) ;EP - CLEAN ZERO NODE WITH NO DATES
  1.  K DIK,DA
  1.  S DIK="^AUPNMCR(",DA=WD0 D ^DIK
  1.  Q
  1. END K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC
  1.  Q
  1. DRAW ;EP
  1.  S AG("PG")="4MCRB"
  1.  S ROUTID=$P($T(+1)," ")  ;SET ROUTINE ID FOR PROGRAMMER VIEW
  1.  D HDR
  1.  D GETAW
  1.  Q
  1. HDR ;
  1.  S AGPAT=$P($G(^DPT(DFN,0)),U)
  1.  S AGCHRT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:"xxxxx")
  1.  S AG("AUPN")=""
  1.  S:$D(^AUPNPAT(DFN,0)) AG("AUPN")=^(0)
  1.  S AGLINE("-")=$TR($J(" ",78)," ","-")
  1.  S AGLINE("EQ")=$TR($J(" ",78)," ","=")
  1.  S $P(AGLINE("PGLN"),"=",81)=""
  1.  W $$S^AGVDF("IOF"),!
  1.  D PROGVIEW^AGUTILS(DUZ)
  1.  W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
  1.  W ?36,"MEDICARE PAGE B"
  1.  W ?80-$L($P($G(^DIC(4,DUZ(2),0)),U)),$P($G(^DIC(4,DUZ(2),0)),U)
  1.  S AGLINE("-")=$TR($J(" ",80)," ","-")
  1.  S AGLINE("EQ")=$TR($J(" ",80)," ","=")
  1.  W !,AGLINE("EQ")
  1.  W !,$E(AGPAT,1,23)
  1.  W ?23,$$DTEST^AGUTILS(DFN)
  1.  I $D(AGCHRT) W ?42,"HRN#:",AGCHRT
  1.  ;GET ELIGIBILITY STATUS
  1.  S AGELSTS=$P($G(^AUPNPAT(DFN,11)),U,12)
  1.  W ?56,"(",$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
  1.  W !,AGLINE("EQ")
  1.  S DA=DFN
  1.  K AG("EDIT")
  1.  Q
  1. GETAW ;DISPLAY
  1.  W !,"MEDICARE SECONDARY PAYER  (Enter ""A"" to add a new MSP reason)"
  1.  W !,AGLINE("-")
  1.  W !,"DATE OBTAINED",?20,"STATUS",?30,"REASON"
  1.  W !,AGLINE("-"),!
  1.  D MSP
  1.  W !,"PART A BENEFITS ",$E(AGLINE("-"),1,28)," PART B BENEFITS ",$E(AGLINE("-"),1,19)
  1.  S PARTAIEN=$$PARTIEN(MCRPTR,"A")
  1.  S PARTBIEN=$$PARTIEN(MCRPTR,"B")
  1.  ;ACTIVATE NEXT THREE LINES IF CO-PAY/DED RATES ARE TO BE ENTERED THROUGH TABLE MAINT.
  1.  S PARTAD0=$$CHKDATES(PARTAIEN) W:'PARTAD0 "NO ACTIVE 'CO-PAY/DED RATES'"
  1.  S PARTBD0=$$CHKDATES(PARTBIEN) W:'PARTBD0 ?45,"NO ACTIVE 'CO-PAY/DED RATES'"
  1.  Q:'PARTAD0&('PARTBD0)
  1.  K AG("C")
  1.  F AG=1:1 D  Q:$G(AGSCRN)[("*END*")
  1.  . S AGSCRN=$P($T(@1+AG),";;",2,15)
  1.  . Q:AGSCRN[("*END*")
  1.  . S CAPTION=$P(AGSCRN,U)  ;FIELD CAPTION
  1.  . S DIC=$P(AGSCRN,U,3)    ;FILE OR SUBFILE #
  1.  . S DR=$P(AGSCRN,U,4)      ;FLD #
  1.  . S NEWLINE=$P(AGSCRN,U,5)  ;NEWLINE OR INDENT
  1.  . S CAPDENT=$P(AGSCRN,U,2)   ;CAPTION INDENT
  1.  . S ITEMNUM=$P(AGSCRN,U,6)   ;ITEM #
  1.  . S TAGCALL=$P(AGSCRN,U,7)   ;TAG TO CALL TO EDIT THIS FLD
  1.  . S EXECUTE=$P(AGSCRN,"|",2)      ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
  1.  . S PREEXEC=$P(AGSCRN,"|",3)
  1.  . S:TAGCALL'="" $P(AG("C"),",",ITEMNUM)=TAGCALL   ;SELECTION STRING
  1.  . W @NEWLINE,ITEMNUM,$S(ITEMNUM'="":". ",1:""),@CAPDENT,$S($G(CAPTION)'="":CAPTION_": ",$G(CAPTION)="":"",1:$P($G(^DD(DIC,DR,0)),U)_": ")
  1.  . I DIC=9000003 D  Q
  1.  .. S D0=DFN
  1.  .. W $$GET1^DIQ(DIC,D0,DR)
  1.  . I DR=.15!(DR=.16)!(DR=.17)!(DR=.18) W $J($$GET1^DIQ(DIC,PARTAD0,DR),10,2)
  1.  . I DR=.19 W $$GET1^DIQ(DIC,PARTAD0,DR)
  1.  . I DR=.21 W $J($$GET1^DIQ(DIC,PARTBD0,DR),10,2)
  1.  . I DR=.22 W $J($$GET1^DIQ(DIC,PARTBD0,DR),10)," %"
  1.  . K PARTAIEN,PARTBIEN
  1.  S AG("N")=$L(AG("C"),",")
  1. CONT ;
  1.  K MYERRS,MYVARS
  1.  D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
  1.  S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="FINDMCR",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
  1.  I '$G(NEWENTRY) D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
  1.  W !,$G(AGLINE("-"))
  1.  D VERIF^AGUTILS
  1.  Q
  1. WMSG ;DISPLAY THIS MSG IF THERE IS NO ENTRY IN THE MEDICARE ELIGIBILITY
  1.  ;GLOBAL
  1.  W !,"You must first enter the MEDICARE ELIGIBILITY"
  1.  Q
  1.  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1.  ; MEDICARE ELIGIBILITY FIELDS
  1.  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1.  ;
  1. DTWC ;
  1. NEWENTRY ;NEW ENTRY
  1.  W !!
  1.  K DIC,DIE,DR,DA
  1.  S DIC="^AUPNMCR("
  1.  S DIC(0)="L"
  1.  S X="`"_DFN
  1.  K DD,DO
  1.  D ^DIC
  1.  Q:+Y'>0
  1.  S WD0=+Y
  1.  S NEWENTRY=0
  1.  Q
  1. MSP ;GET DATA FROM AUPNMSP
  1.  N DIFF,X,X1,X2  ;AG*7.1*10 - Fixing bug (below)
  1.  S AG("MSPDT")="",AG("CNT")=0
  1.  ;IS LAST MSP DATE GREATER THAN 89 DAYS
  1.  S MSPALERT=0
  1.  S LASTMSP=$O(^AUPNMSP("C",DFN,AG("MSPDT")),-1)
  1.  S X1=DT,X2=LASTMSP D ^%DTC S DIFF=X ;AG*7.1*10 - Fixing bug
  1.  ;I (DT-LASTMSP)>89 S MSPALERT=1
  1.  ;AG*7.1*10 - Commented out next line and replaced with the following 2 lines to fix bug
  1.  ;I $$ACTELIG^AGEDERR2(DFN,"^MCR"),((DT-LASTMSP)>89) S MSPALERT=1  ;AG*7.1*1 IM19440 IF NO ACTIVE MEDICARE DON'T CHECK
  1.  I $$ACTELIG^AGEDERR2(DFN,"^MCR"),'DIFF!(DIFF>89) S MSPALERT=1
  1.  K DIFF,X,X1,X2
  1.  ;
  1.  F  S AG("MSPDT")=$O(^AUPNMSP("C",DFN,AG("MSPDT")),-1) Q:'AG("MSPDT")  D
  1.  . S AG("REC")=0
  1.  . F  S AG("REC")=$O(^AUPNMSP("C",DFN,AG("MSPDT"),AG("REC"))) Q:'AG("REC")!(AG("CNT")=4)  D
  1.  .. W ?1,$$GET1^DIQ(9000037,AG("REC"),.01)
  1.  .. W ?20,$$GET1^DIQ(9000037,AG("REC"),.03)
  1.  .. W ?30,$$GET1^DIQ(9000037,AG("REC"),.04)
  1.  .. W ?79,$S(MSPALERT:"A",1:"")
  1.  .. W !
  1.  .. S AG("CNT")=AG("CNT")+1
  1.  K AG("MSPDT"),AG("REC"),AG("CNT")
  1.  Q
  1. ADDMSP ;
  1.  K DIR,DIC,DIE,DA,DR,X,Y,D0,DD
  1.  S DIC("DR")=""
  1.  S DIC="^AUPNMSP("
  1.  S DIC(0)="AELQMZ"
  1.  S DIC("S")="I $P(^(0),U,2)=DFN&($P($G(^(7)),U)="""")"
  1.  D ^DIC
  1.  Q:Y<0
  1.  S DIE=DIC
  1.  S DA=+Y
  1.  S DR=".02////^S X=WD0"
  1.  D ^DIE
  1.  S DR=".03R;S:X=""N"" Y=0;.04R"
  1.  D ^DIE
  1.  Q
  1. INPDED ;INPATIENT DEDUCTIBLE
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTAIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.15
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. COINS61 ;CO-INSURANCE (61-90)
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTAIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.16
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. LIFRES ;LIFETIME RESERVE
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTAIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.17
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. SNF ;SNF C0-INSURANCE
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTAIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.18
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. DED ;PART B DEDUCTIBLE
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTBIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.21
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. COINS ;PART B CO-INSURANCE
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTBIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.22
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. MCRDAY ;MEDICARE DAYS
  1.  K DIC,DR,DIE,DA,DD,D0
  1.  S DA(1)=PARTAIEN
  1.  S DIE="^AUTTPIC("_DA(1)_",19,"
  1.  S DR=.19
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1.  ;
  1.  ;WILL USE THESE NEXT TWO SUBROUTINESS
  1.  ;MAYBE IF CLERKS ARE ALLOWED TO EDIT THESE FIELDS
  1.  ;THEY NEED TO BE RE WRITTEN
  1. LSTAREC ;FIND LAST PART A RECORD
  1.  S PARTAIEN=$$PARTIEN(MCRPTR,"A")
  1.  ;I PARTAIEN="" w !,"NO ""PART A"" COVERAGE TYPE FOUND IN THE COVERAGE TYPE FILE","PLEASE ENTER A ""PART A"" COVERAGE TYPE WITH 'MEDICARE' AS THE INSURER" 
  1.  S AG("COVDT")=$O(^AUTTPIC(MCRPTR,19,"B",""),-1)
  1.  I AG("COVDT")="" D
  1.  .K DIC
  1.  .S DA(1)=PARTAIEN
  1.  .S DIC="^AUTTPIC("_DA(1)_",19,"
  1.  .S DIC(0)="AELMQ"
  1.  .S DIC("P")=$P($G(^DD(9999999.65,19,0)),U,2)
  1.  .S DIC("A")="Enter the start date for the Part A benefits "
  1.  .D ^DIC
  1.  .S:Y'=-1 AG("COVDT")=$P(Y,U,2)
  1.  .Q:Y=-1
  1.  I AG("COVDT")="" Q
  1.  S AG("REC")=$O(^AUTTPIC(PARTAIEN,19,"B",AG("COVDT"),""),-1)
  1.  S DA=AG("REC")
  1.  Q
  1. LSTBREC ;FIND LAST PART B RECORD
  1.  S PARTBIEN=$$PARTIEN(MCRPTR,"B")
  1.  I PARTBIEN="" W !,"NO ""PART B"" COVERAGE TYPE FOUND IN THE COVERAGE TYPE FILE","PLEASE ENTER A ""PART B"" COVERAGE TYPE WITH MEDICARE AS THE INSURER"
  1.  S AG("COVDT")=$O(^AUTTPIC(PARTBIEN,19,"B",""),-1)
  1.  I AG("COVDT")="" D
  1.  .K DIC
  1.  .S DA(1)=PARTBIEN
  1.  .S DIC="^AUTTPIC("_DA(1)_",19,"
  1.  .S DIC(0)="AELMQ"
  1.  .S DIC("P")=$P($G(^DD(9999999.65,19,0)),U,2)
  1.  .S DIC("A")="Enter the start date for the Part B benefits. "
  1.  .D ^DIC
  1.  .S:Y'=-1 AG("COVDT")=$P(Y,U,2)
  1.  .Q:Y=-1
  1.  I AG("COVDT")="" Q
  1.  S AG("REC")=$O(^AUTTPIC(PARTBIEN,19,"B",AG("COVDT"),""),-1)
  1.  S DA=AG("REC")
  1.  Q
  1.  ;RETURN PART IEN
  1. PARTIEN(MCRPTR,PART) ;
  1.  S FOUND=0,RETURN=0
  1.  N PARTIEN
  1.  S PARTIEN=""
  1.  F  S PARTIEN=$O(^AUTTPIC("C",MCRPTR,PARTIEN)) Q:'PARTIEN!(FOUND)  D
  1.  .I $P($G(^AUTTPIC(PARTIEN,0)),U)=("PART "_PART) S FOUND=1,RETURN=PARTIEN Q
  1.  Q RETURN
  1.  ;CHECK FOR WHICH 19 NODE WE NEED BASED ON THE START DATES ENTERED
  1.  ;WHEN ACTIVE DATE FOUND RETURN D0 FOR USE IN GET1 CALL
  1. CHKDATES(PARTIEN) ;
  1.  N RETURN,DTREC
  1.  S RETURN=0
  1.  S EFFDT=""
  1.  F  S EFFDT=$O(^AUTTPIC(PARTIEN,19,"B",EFFDT)) Q:'EFFDT  D
  1.  .S ENDDT=$O(^AUTTPIC(PARTIEN,19,"B",EFFDT))
  1.  .S ACTIVE=$$ISACTIVE^AGUTILS(EFFDT,ENDDT)
  1.  .I ACTIVE S DTREC=$O(^AUTTPIC(PARTIEN,19,"B",EFFDT,"")) S RETURN=DTREC_","_PARTIEN_","
  1.  Q RETURN
  1.  ; ****************************************************************
  1.  ; ON LINES BELOW:
  1.  ; U "^" DELIMITED
  1.  ; PIECE 1= FLD LBL
  1.  ; PIECE 2= POSITION ON LINE TO DISP ITEM #
  1.  ; PIECE 3= FILE #
  1.  ; PIECE 4= FLD #
  1.  ; PIECE 5= NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE CAP
  1.  ; PIECE 6= ITEM # OVERIDE. USE THIS TO OVERIDE THE ITEM # USED TO CHOOSE THIS
  1.  ;          FLD ON THE SCREEN
  1.  ; PIECE 7= TAG TO CALL WHEN THIS FLD IS CHOSEN TO EDIT
  1.  ;
  1.  ; BAR "|" DELIMITED
  1.  ; 2      EXECUTE    EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFTER FLD PRINT
  1.  ; 3      PREEXEC    EXECUTE CODE TO DO BEFORE FLD PRINTS.
  1.  ;                   USE TO SCREEN OUT PRINTING A FLD VALUE
  1.  ; 4      PRECAPEX   EXECUTE CODE TO DO BEFORE PRINTING THE CAP OR FLD LBL.
  1.  ;                   USE TO SCREEN OUT PRINTING A CAP/FLD LBL
  1.  ; 5      POSTEXEC   EXECUTE CODE TO DO AFTER PRINTING THE FLD DATA
  1.  ;QMB/SLMB...............^?3^9000003^.08^!^8^QMBSLMB
  1. 1 ;
  1.  ;;Inpatient Deductible...^?3^9999999.6519^.15^!^1^INPDED
  1.  ;;Deductible..^?40^9999999.6519^.21^?45^5^DED
  1.  ;;Co-insurance (61-90)...^?3^9999999.6519^.16^!^2^COINS61
  1.  ;;Co-insurance^?40^9999999.6519^.22^?45^6^COINS
  1.  ;;Lifetime Reserve.......^?3^9999999.6519^.17^!^3^LIFRES
  1.  ;;SNF Co-insurance.......^?3^9999999.6519^.18^!^4^SNF
  1.  ;;Medicare Days..........^?3^9999999.6519^.19^!!^7^MCRDAY
  1.  ;;*END*