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