AGED4PD ;IHS/ASDS/TPF - EDIT/DISPLAY MEDICARE PHARMACY PAGE ;
;;7.1;PATIENT REGISTRATION;**1,2,11**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
;
EN(COMPIEN) ;EP - CALLED BY AG4
;
S ID0=$P(COMPIEN,",")
S ID1=$P(COMPIEN,",",3)
S AG("PG")="4MCRD"
S ROUTID=$P($T(+1)," ")
S CALLER="SCREEN"
VAR ;
I $G(EXIT) K EXIT Q
D DRAW
I $D(AGSEENLY) K DIR S DIR(0)="E",DIR("A")="Enter Response" D ^DIR Q
W !,AGLINE("EQ")
K DIR
I $D(^XUSEC("AGZMGR",DUZ)) D
.S DIR("A")="ENTER ACTION (<E>dit a field,<D>elete eligibility date:"
.S DIR(0)="SAO^E:EDIT;D:DELETE"
E S DIR("A")="ENTER ACTION <E>dit a field:",DIR(0)="SAO^E:EDIT"
D ^DIR
Q:Y=$G(AGOPT("ESCAPE"))
I '$D(AGSEENLY) I $D(MYERRS("C","E")),(Y'?1N.N),(Y'="E"),(Y'="V"),(Y'="A"),(Y'="D") W !,"ERRORS ON THIS PAGE. PLEASE EDIT BEFORE EXITING!!" H 3 G VAR
I Y="" D CLEAN(ID0) Q
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
I Y="E" D EDIT G VAR
I Y="D" D EDIT G VAR
W !,"COMMAND "_Y_" UNKNOWN!" H 3
G VAR
EDIT ;EP
K DIR
S DIR("A")="CHANGE which item? (1-"_$G(AG("N"))_") NONE// "
S DIR(0)="LO^1:"_$G(AG("N"))
D ^DIR
I Y=$G(AGOPT("ESCAPE")) S EXIT=1 Q
S CHOICES=Y
I '$D(AGSEENLY) I ($D(MYERRS("C","E"))&(Y'?1N.N)),(Y'["V"),(Y'=$G(AGOPT("ESCAPE"))) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 Q
Q:Y=$G(AGOPT("ESCAPE"))
Q:$D(DLOUT)!(Y["N")!$D(DUOUT)
Q:$D(DFOUT)!$D(DTOUT)
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 Q
S AGY=Y
F AGI=1:1 S AG("SEL")=+$P(AGY,"|",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N")) D
.I AG("SEL")>12 D EDITPOLM^AGEDPRVI(.POLMEMBS,CHOICES) Q
.D @($P(AG("C"),"|",AG("SEL")))
;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
S COMPIEN=ID0_",11,"_ID1_","_0
;S AGSELECT=$$UPDTSEL^AGUTILS("FINDPVT",.AGINS,COMPIEN)
;S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2)) ;AG*7.1*1 IM18549 ERROR IN ERROR MSG UPDATE
S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P($G(AGSELECT),U,2)) ;AG*7.1*2 ERRO DURING ALPHA TESTING
D UPDATE1^AGED(DUZ(2),ID0,3,"")
K AGI,AGY
Q
CLEAN(ID0) ;EP - CLEAN EMPTY RECORD. IF NO PRIVATE INSURER HAS BEEN ENTERED,
;THE RECORD IS MEANINGLESS
I '$O(^AUPNPRVT(ID0,11,0)) D CLEANZER(ID0)
Q
CLEANZER(ID0) ;EP - CLEAN ZERO NODE WITH NO INFOR
K DIK,DA
S DIK="^AUPNPRVT(",DA=ID0 D ^DIK
Q
END ;EP - CLEAN UP THE VARS
K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y
K ADA,WDA,ADT,WDT,REC,NEWENTRY,POLPTR,ID0,ID1,CALLER
Q
DRAW ;EP - MAIN SCREEN DRAW
D HDR
D GETAW
Q
HDR ;
S AGPAT=$P($G(^DPT(ID0,0)),U)
S AGCHRT=$S($D(^AUPNPAT(ID0,41,DUZ(2),0)):$P($G(^AUPNPAT(ID0,41,DUZ(2),0)),U,2),1:"xxxxx")
S AG("AUPN")=""
S:$D(^AUPNPAT(ID0,0)) AG("AUPN")=^(0)
S AGLINE("-")=$TR($J(" ",78)," ","-")
S AGLINE("EQ")=$TR($J(" ",78)," ","=")
S $P(AGLINE("PGLN"),"=",81)=""
W $$S^AGVDF("IOF"),!
S ROUTID=$P($T(+1)," ")
S SUBS=$P($G(AGSELECT),U,11)
D PROGVIEW^AGUTILS(DUZ,SUBS)
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
W ?36,"Medicare Pharmacy"
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(ID0)
I $D(AGCHRT) W ?42,"HRN#:",AGCHRT
;GET ELIG STAT
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")
;K AG("EDIT") AG:*7.1*2 TO ALLOW QUIT FROM AG6 WHEN EDITING PATIENT RATHER THAN ADDING A PATIENT
Q
GETAW ;EP - DISPLAY THE SCREEN
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) ;FLD CAP
. I $E(CAPTION)="-" W !,CAPTION Q ;- DENOTES SECTION
. 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) ;CAP INDENT
. S ITEMNUM=$P(AGSCRN,U,6) ;ITEM #
. S TAGCALL=$TR($P($P(AGSCRN,U,7),"|",1),"~",U) ;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) ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
. S PRECAPEX=$P(AGSCRN,"|",4) ;PLACE CODE TO EXECUTE BEF CAP/FLD LBL
. S POSTEXEC=$P(AGSCRN,"|",5) ;PLACE ANYTHING HERE TO BE EXECUTED AFT DISP OF THE FLD
. S:TAGCALL'="" $P(AG("C"),"|",ITEMNUM)=TAGCALL ;SELECTION STRING
. W @NEWLINE
. W ITEMNUM
. W $S(ITEMNUM'="":") ",1:"")
. I PRECAPEX="" W @CAPDENT,$S($G(CAPTION)'="":CAPTION_": ",$G(CAPTION)="":"",1:$P($G(^DD(DIC,DR,0)),U)_": ")
. I PRECAPEX'="" X PRECAPEX I $T W @CAPDENT,$S($G(CAPTION)'="":CAPTION_": ",$G(CAPTION)="":"",1:$P($G(^DD(DIC,DR,0)),U)_": ")
.;IF EDITING DISP DATA
.;E DISP ONLY THE CAPS
.I 'NEWENTRY D
.. S D0=ID0
.. I DIC'["." S D0=D0_","
.. E S D0=ID1_","_D0_","
.. S FLAG=""
.. I DIC=9999999.18 S D0=$G(AGINSPTR) I DR=.21 S FLAG="I"
.. ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP
.. N PIECE
.. S VDR=DR
.. F PIECE=1:1 S DR=$P(VDR,";",PIECE) Q:DR="" D
... I $P(PREEXEC,";",PIECE)'="" X $P(PREEXEC,";",PIECE)
... I $P(EXECUTE,";",PIECE)="" D
.... I DIC=9999999.18,(DR=.01) S PLANPTR=$P($G(^AUPNMCR(ID0,11,ID1,0)),U,4)
.... I DIC=9999999.18 S D0=$G(PLANPTR)
.... I DIC=9000003.11,(DR=.05) S COVPTR=$P($G(^AUPNMCR(ID0,11,ID1,0)),U,11),GRPPTR=$P($G(^AUPNMCR(ID0,11,ID1,0)),U,11)
.... I DIC=9000003.11,(DR=.04) S AGELP("INS")=$$GET1^DIQ(DIC,D0,DR,FLAG)
.... S DIC("S")="I $D(AGELP(""INS"")),$P(^(0),U,2)=AGELP(""INS"")"
.... I DIC=9999999.77 S D0=$G(GRPPTR)
.... I DIC=9999999.6519 D Q:DT1=""
..... S D0=$G(COVPTR),DT1=$O(^AUTTPIC(37,19,"B",DT+.01),-1) Q:DT1=""
..... S DT1=$O(^AUTTPIC(37,19,"B",DT1,""))
..... S D0=DT1_","_D0_","
.... I DIC=9000003.11,(DR=.01) D GETDATES(ID0) Q ;DISPLAY DATES AFTER STANDARD REG. SORT
.... I DIC=9999999.6519,((DR=.23)!(DR=.24)!(DR=.25)) W $J($$GET1^DIQ(DIC,D0,DR,FLAG),10,2)
.... E W $$GET1^DIQ(DIC,D0,DR,FLAG)
... I $P(EXECUTE,";",PIECE)'="" S D0=$TR(D0,",") X $P(EXECUTE,";",PIECE)
... I $P(POSTEXEC,";",PIECE)'="" X $P(POSTEXEC,";",PIECE)
..K PIECE,VDR
S AG("N")=$L(AG("C"),"|")
W !,$G(AGLINE("-"))
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=ID0,MYVARS("FINDCALL")="FINDPVT"
S MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
I '$G(NEWENTRY) D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
D VERIF^AGUTILS
Q
GETDATES(ID0) ;EP - GET THE DTS USING LIST^DIC
K RESULT,ERROR
S FLAGS=""
S FIELDS=";.01I;.02I;.03I"
D LIST^DIC(9000003.11,","_ID0_",",FIELDS,FLAGS,"*",,,,,,"RESULT","ERROR")
D DATESORT(.RESULT)
Q
DATESORT(RESULT) ;EP - TAKE LIST RETURNED BY FILE^DIC AND SORT IT
;BASED ON SPECS
N DATESORT,SPECSUB,EFFDT,ENDDT,CVG
S REC=0
F S REC=$O(RESULT("DILIST","ID",REC)) Q:'REC D
.S ENDDT=RESULT("DILIST","ID",REC,.02)
.S EFFDT=RESULT("DILIST","ID",REC,.01)
.S CVG=RESULT("DILIST","ID",REC,.03)
.Q:CVG'="D"
.S SPECSUB=$S(ENDDT="":"O",1:"T") ;O=OPEN ENDED, T=TERM DATE
.I SPECSUB="O" S DATESORT(SPECSUB,EFFDT)=ENDDT_U_CVG
.E S DATESORT(SPECSUB,-ENDDT)=EFFDT_U_CVG
S DEFEDDT=$O(DATESORT("O","")) ;GET DEFAULT EDIT DT. FIRST ONE IN DISP
I DEFEDDT="" S DEFEDDT=$O(DATESORT("T","")) S:DEFEDDT'="" DEFEDDT=$P(DATESORT("T",DEFEDDT),U)
D SHOWNEW(.DATESORT)
Q
SHOWNEW(DATESORT) ;EP
N SPECSUB,DATE,DATE1,CVG,EFFDT,ENDDT,REC
S SPECSUB=""
S REC=1
I '$D(DATESORT("O")) F S SPECSUB=$O(DATESORT(SPECSUB)) Q:SPECSUB="" D ALLTERM Q
F S SPECSUB=$O(DATESORT(SPECSUB)) Q:SPECSUB="" D
.S DATE=""
.F S DATE=$O(DATESORT(SPECSUB,DATE)) Q:DATE="" D
..S DATE1=$P(DATESORT(SPECSUB,DATE),U)
..S CVG=$P(DATESORT(SPECSUB,DATE),U,2)
..I SPECSUB="O" S EFFDT=DATE,ENDDT=""
..E S EFFDT=DATE1,ENDDT=-DATE
..I REC'=1 W !
..S Y=EFFDT X ^DD("DD")
..W ?3,Y
..;W ?57,CVG
..S Y=ENDDT X ^DD("DD")
..W ?40,Y
..W ?79,$S($$ISACTIVE^AGINS(EFFDT,ENDDT):"A",1:"I")
..I $$ISACTIVE^AGINS(EFFDT,ENDDT) S DEFEDDT=EFFDT
..S REC=REC+1
Q
ALLTERM ;EP
S DATE=""
F S DATE=$O(DATESORT(SPECSUB,DATE),-1) Q:DATE="" D
.S DATE1=$P(DATESORT(SPECSUB,DATE),U)
.S CVG=$P(DATESORT(SPECSUB,DATE),U,2)
.I SPECSUB="O" S EFFDT=DATE,ENDDT=""
.E S EFFDT=DATE1,ENDDT=-DATE
.I REC'=1 W !
.S Y=EFFDT X ^DD("DD")
.W ?3,Y
.;W ?57,CVG
.S Y=ENDDT X ^DD("DD")
.W ?40,Y
.W ?79,$S($$ISACTIVE^AGINS(EFFDT,ENDDT):"A",1:"I")
.I $$ISACTIVE^AGINS(EFFDT,ENDDT) S DEFEDDT=EFFDT
.S REC=REC+1
Q
WMSG ;EP - DISP THIS MSG IF THIS IS A NEW ENTRY
W !,"Editing Pharmacy Medicare Part D Eligibility record"
Q
;;;;;;;;;;;;;;;;;;;;;;;;;;
; EDIT MEDICARE PART D FLDS
;;;;;;;;;;;;;;;;;;;;;;;;;;
EDITNAME(ID0,ID1) ;EP - EDIT MEDICARE NAME
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=".05R"
D ^DIE
K DIE,DIC,DA,DR
Q
EDITGEN(ID0,ID1) ;EP - EDIT GENDER
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=".08R"
D ^DIE
K DIE,DIC,DA,DR
Q
EDITID(ID0,ID1) ;EP - EDIT ID NUmber
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=".06R"
D ^DIE
K DIE,DIC,DA,DR
Q
EDITDOB(ID0,ID1) ;EP - EDIT DOB
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=".09R"
D ^DIE
K DIE,DIC,DA,DR
Q
EDITPC(ID0,ID1) ;EP - EDIT PERSON CODE
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=.07
D ^DIE
K DIE,DIC,DA,DR
Q
EDITCOV(ID0,ID1) ;EP - EDIT COVERAGE TYPE PTR
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=.12
D ^DIE
K DIE,DIC,DA,DR
Q
ADDEFF(ID0) ;EP - ADD/EDIT NEW EFFECTIVE DATE
K DIE,DIC,DA,DR
I $G(DEFEDDT)'="" S DIC("B")=DEFEDDT ;IF DEFAULT USE IT
S DA(1)=ID0
S DIC(0)="AE"
S DIC="^AUPNMCR("_DA(1)_",11,"
S DIC("S")="I $P($G(^(0)),U,3)=""D"""
D ^DIC
I +Y<0 Q
K DIE,DIC,DA,DR
D EFFDT(ID0,+Y)
Q
EFFDT(ID0,ID1) ;EP - EDIT EFFECTIVE DATE
K DIE,DIC,DA,DR,DIDEL,ONLYONE,IEN
I $D(^XUSEC("AGZMGR",DUZ)) S DIDEL=9000003.11
S IEN=0 F ONLYONE=1:1 S IEN=$O(^AUPNMCR(ID0,11,IEN)) Q:'IEN
S DA=ID1
S DA(1)=ID0
S DIE="^AUPNMCR("_DA(1)_",11,"
I ONLYONE=1 D
.W !!,"THERE IS ONLY ONE ELGIBILITY DATE RECORD FOR THIS PHARMACY ELIGIBILITY"
.W !,"IF YOU DELETE THIS DATE THE ENTIRE PHARMACY DATA WILL BE DELETED FOR THIS"
.W !,"PATIENT"
.W !
.S DR=".01R"
.S DR(2,9000003.11)=".01R"
E S DR=".01",DR(2,9000003.11)=".01"
D ^DIE
Q:'$D(DA) ;IF NO DA, ENTRY WAS DELETED
K DIE,DIC,DA,DR
I $D(^AUPNMCR(ID0,11,ID1,0)) D EDITEXP(ID0,ID1)
E S EXIT=1
Q
EDITEXP(ID0,ID1) ;EP - EDIT EXPIRATION DATE
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=.02
D ^DIE
K DIE,DIC,DA,DR
Q
EDITGRP(ID0,ID1) ;EP - EDIT GROUP NAME
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=.11
D ^DIE
K DIE,DIC,DA,DR
Q
EDITPLAN(ID0,ID1) ;EP - EDIT PLAN
K DIE,DIC,DA,DR
S DA(1)=ID0
S DA=ID1
S DIE="^AUPNMCR("_DA(1)_",11,"
S DR=".04R"
D ^DIE
K DIE,DIC,DA,DR
Q
EDITSTBN(COVPTR) ;EP - EDIT START BENEFIT
K DIE,DIC,DA,DR
W !,"SPECIFICATIONS NOT YET PROVIDED!" H 3
K DIE,DIC,DA,DR
Q
EDITDED(COVPTR) ;EP - EDIT DEDUCTIBLE
K DIE,DIC,DA,DR
W !,"SPECIFICATIONS NOT YET PROVIDED!" H 3
K DIE,DIC,DA,DR
Q
EDITCOP(COVPTR) ;EP - EDIT CO-PAY
K DIE,DIC,DA,DR
W !,"SPECIFICATIONS NOT YET PROVIDED!" H 3
K DIE,DIC,DA,DR
Q
;FIELD EDITS
; ****************************************************************
; ON LINES BELOW:
; U "^" DELIMITED
; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
; PIECE VAR DESC
; ----- -------- -----------------------------------------------
; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
; 2 CAPDENT POSITION ON LINE TO DISP CAP
; 3 DIC FILE OR SUBFILE #
; 4 DR FLD # - THESE CAN BE SEPARATED BY ";" THIS ALLOWS
; MULTIPLE FLDS TO BE PRINTED WITH THE SAME CAP AS IN
; 'CITY,STATE,ZIP'
; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE LINE
; 6 ITEMNUM ITEM # ASSIGNMENT. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
; FLD ON THE SCREEN
; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
;
; BAR "|" DELIMITED
; PIECE VAR DESC
; ----- -------- ----------------------------------------------
; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO.
; EXECUTED AFT FLD PRINT. IF MUTLIPLE FLDS ARE PRINTED
; THEN MULTIPLE EXECUTE CODES CAN BE SEPARATED BY ";".
; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS. USE TO SCREEN OUT
; PRINTING A FLD VALUE. FOR MULTIPLES SEPARATE BY ";"
; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
; FOR MULTIPLES SEPARATE BY ";"
;
;FIELDS BELOW DELETED PER ADRIAN 12/13/05
;Coverage Type^?3^9000003.11^.12^?49^^^||||
;Co-Pay.......^?3^9999999.6519^.25^?44^11^EDITCOP(COVPTR)||||
;Deductible...^?3^9999999.6519^.24^?44^10^EDITDED(COVPTR)^||||
;Begin Date...^?3^9999999.6519^.01^?49^^||||
;Start Benefit^?3^9999999.6519^.23^?44^9^EDITSTBN(COVPTR)^||||
;Ins. Type^?3^9999999.18^.21^?23^^^||||
1 ;
;;------------------MEDICARE PART D DATA-----------------------------------------
;;Medicare Name^?3^9000003.11^.05^!^1^EDITNAME(ID0,ID1)^||||W ?49,$C(124)
;;Gender^?3^9000003.11^.08^?49^4^EDITGEN(ID0,ID1)^||||
;;ID Number^?3^9000003.11^.06^!^2^EDITID(ID0,ID1)^||||W ?49,$C(124)
;;Date of Birth^?3^9000003.11^.09^?49^5^EDITDOB(ID0,ID1)^||||
;;Person Code^?3^9000003.11^.07^!^3^EDITPC(ID0,ID1)^||||
;;-ELIGIBILITY DATES--------------------------------------------------------------
;;-----Effective Date-----------------------Expire Date---------------------------
;;^?3^9000003.11^.01^!^6^ADDEFF(ID0)^||||
;;--------------------------------------------------------------------------------
;;Grp Name^?3^9000003.11^.11^!^7^EDITGRP(ID0,ID1)^||||
;;Grp Number^?3^9999999.77^.02^?45^^^||||
;;--------------------------------------------------------------------------------
;;^?3^9999999.18^.01^!^8^EDITPLAN(ID0,ID1)^||||
;;^?3^9999999.18^.02^!^^^||||
;;^?3^9999999.18^.03^!^^||||W ","
;;^?3^9999999.18^.04^?0^^||||W " "
;;^?3^9999999.18^.05^?0^^||||
;;^?3^9999999.18^.06^!^^||||
;;*END*
AGED4PD ;IHS/ASDS/TPF - EDIT/DISPLAY MEDICARE PHARMACY PAGE ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,11**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
+3 ;
EN(COMPIEN) ;EP - CALLED BY AG4
+1 ;
+2 SET ID0=$PIECE(COMPIEN,",")
+3 SET ID1=$PIECE(COMPIEN,",",3)
+4 SET AG("PG")="4MCRD"
+5 SET ROUTID=$PIECE($TEXT(+1)," ")
+6 SET CALLER="SCREEN"
VAR ;
+1 IF $GET(EXIT)
KILL EXIT
QUIT
+2 DO DRAW
+3 IF $DATA(AGSEENLY)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter Response"
DO ^DIR
QUIT
+4 WRITE !,AGLINE("EQ")
+5 KILL DIR
+6 IF $DATA(^XUSEC("AGZMGR",DUZ))
Begin DoDot:1
+7 SET DIR("A")="ENTER ACTION (<E>dit a field,<D>elete eligibility date:"
+8 SET DIR(0)="SAO^E:EDIT;D:DELETE"
End DoDot:1
+9 IF '$TEST
SET DIR("A")="ENTER ACTION <E>dit a field:"
SET DIR(0)="SAO^E:EDIT"
+10 DO ^DIR
+11 IF Y=$GET(AGOPT("ESCAPE"))
QUIT
+12 IF '$DATA(AGSEENLY)
IF $DATA(MYERRS("C","E"))
IF (Y'?1N.N)
IF (Y'="E")
IF (Y'="V")
IF (Y'="A")
IF (Y'="D")
WRITE !,"ERRORS ON THIS PAGE. PLEASE EDIT BEFORE EXITING!!"
HANG 3
GOTO VAR
+13 IF Y=""
DO CLEAN(ID0)
QUIT
+14 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+15 IF Y="E"
DO EDIT
GOTO VAR
+16 IF Y="D"
DO EDIT
GOTO VAR
+17 WRITE !,"COMMAND "_Y_" UNKNOWN!"
HANG 3
+18 GOTO VAR
EDIT ;EP
+1 KILL DIR
+2 SET DIR("A")="CHANGE which item? (1-"_$GET(AG("N"))_") NONE// "
+3 SET DIR(0)="LO^1:"_$GET(AG("N"))
+4 DO ^DIR
+5 IF Y=$GET(AGOPT("ESCAPE"))
SET EXIT=1
QUIT
+6 SET CHOICES=Y
+7 IF '$DATA(AGSEENLY)
IF ($DATA(MYERRS("C","E"))&(Y'?1N.N))
IF (Y'["V")
IF (Y'=$GET(AGOPT("ESCAPE")))
WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"
HANG 3
QUIT
+8 IF Y=$GET(AGOPT("ESCAPE"))
QUIT
+9 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
QUIT
+10 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
+11 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
QUIT
+12 SET AGY=Y
+13 FOR AGI=1:1
SET AG("SEL")=+$PIECE(AGY,"|",AGI)
IF AG("SEL")<1!(AG("SEL")>AG("N"))
QUIT
Begin DoDot:1
+14 IF AG("SEL")>12
DO EDITPOLM^AGEDPRVI(.POLMEMBS,CHOICES)
QUIT
+15 DO @($PIECE(AG("C"),"|",AG("SEL")))
End DoDot:1
+16 ;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
+17 SET COMPIEN=ID0_",11,"_ID1_","_0
+18 ;S AGSELECT=$$UPDTSEL^AGUTILS("FINDPVT",.AGINS,COMPIEN)
+19 ;S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2)) ;AG*7.1*1 IM18549 ERROR IN ERROR MSG UPDATE
+20 ;AG*7.1*2 ERRO DURING ALPHA TESTING
SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$PIECE($GET(AGSELECT),U,2))
+21 DO UPDATE1^AGED(DUZ(2),ID0,3,"")
+22 KILL AGI,AGY
+23 QUIT
CLEAN(ID0) ;EP - CLEAN EMPTY RECORD. IF NO PRIVATE INSURER HAS BEEN ENTERED,
+1 ;THE RECORD IS MEANINGLESS
+2 IF '$ORDER(^AUPNPRVT(ID0,11,0))
DO CLEANZER(ID0)
+3 QUIT
CLEANZER(ID0) ;EP - CLEAN ZERO NODE WITH NO INFOR
+1 KILL DIK,DA
+2 SET DIK="^AUPNPRVT("
SET DA=ID0
DO ^DIK
+3 QUIT
END ;EP - CLEAN UP THE VARS
+1 KILL AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y
+2 KILL ADA,WDA,ADT,WDT,REC,NEWENTRY,POLPTR,ID0,ID1,CALLER
+3 QUIT
DRAW ;EP - MAIN SCREEN DRAW
+1 DO HDR
+2 DO GETAW
+3 QUIT
HDR ;
+1 SET AGPAT=$PIECE($GET(^DPT(ID0,0)),U)
+2 SET AGCHRT=$SELECT($DATA(^AUPNPAT(ID0,41,DUZ(2),0)):$PIECE($GET(^AUPNPAT(ID0,41,DUZ(2),0)),U,2),1:"xxxxx")
+3 SET AG("AUPN")=""
+4 IF $DATA(^AUPNPAT(ID0,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 SET ROUTID=$PIECE($TEXT(+1)," ")
+10 SET SUBS=$PIECE($GET(AGSELECT),U,11)
+11 DO PROGVIEW^AGUTILS(DUZ,SUBS)
+12 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+13 WRITE ?36,"Medicare Pharmacy"
+14 WRITE ?80-$LENGTH($PIECE($GET(^DIC(4,DUZ(2),0)),U)),$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+15 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+16 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",80)," ","=")
+17 WRITE !,AGLINE("EQ")
+18 WRITE !,$EXTRACT(AGPAT,1,23)
+19 WRITE ?23,$$DTEST^AGUTILS(ID0)
+20 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",AGCHRT
+21 ;GET ELIG STAT
+22 SET AGELSTS=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+23 WRITE ?56,"(",$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
+24 WRITE !,AGLINE("EQ")
+25 ;K AG("EDIT") AG:*7.1*2 TO ALLOW QUIT FROM AG6 WHEN EDITING PATIENT RATHER THAN ADDING A PATIENT
+26 QUIT
GETAW ;EP - DISPLAY THE SCREEN
+1 KILL AG("C")
+2 FOR AG=1:1
Begin DoDot:1
+3 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,15)
+4 IF AGSCRN[("*END*")
QUIT
+5 ;FLD CAP
SET CAPTION=$PIECE(AGSCRN,U)
+6 ;- DENOTES SECTION
IF $EXTRACT(CAPTION)="-"
WRITE !,CAPTION
QUIT
+7 ;FILE OR SUBFILE #
SET DIC=$PIECE(AGSCRN,U,3)
+8 ;FLD #
SET DR=$PIECE(AGSCRN,U,4)
+9 ;NEWLINE OR INDENT
SET NEWLINE=$PIECE(AGSCRN,U,5)
+10 ;CAP INDENT
SET CAPDENT=$PIECE(AGSCRN,U,2)
+11 ;ITEM #
SET ITEMNUM=$PIECE(AGSCRN,U,6)
+12 ;TAG TO CALL TO EDIT THIS FLD
SET TAGCALL=$TRANSLATE($PIECE($PIECE(AGSCRN,U,7),"|",1),"~",U)
+13 ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
SET EXECUTE=$PIECE(AGSCRN,"|",2)
+14 ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
SET PREEXEC=$PIECE(AGSCRN,"|",3)
+15 ;PLACE CODE TO EXECUTE BEF CAP/FLD LBL
SET PRECAPEX=$PIECE(AGSCRN,"|",4)
+16 ;PLACE ANYTHING HERE TO BE EXECUTED AFT DISP OF THE FLD
SET POSTEXEC=$PIECE(AGSCRN,"|",5)
+17 ;SELECTION STRING
IF TAGCALL'=""
SET $PIECE(AG("C"),"|",ITEMNUM)=TAGCALL
+18 WRITE @NEWLINE
+19 WRITE ITEMNUM
+20 WRITE $SELECT(ITEMNUM'="":") ",1:"")
+21 IF PRECAPEX=""
WRITE @CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION_": ",$GET(CAPTION)="":"",1:$PIECE($GET(^DD(DIC,DR,0)),U)_": ")
+22 IF PRECAPEX'=""
XECUTE PRECAPEX
IF $TEST
WRITE @CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION_": ",$GET(CAPTION)="":"",1:$PIECE($GET(^DD(DIC,DR,0)),U)_": ")
+23 ;IF EDITING DISP DATA
+24 ;E DISP ONLY THE CAPS
+25 IF 'NEWENTRY
Begin DoDot:2
+26 SET D0=ID0
+27 IF DIC'["."
SET D0=D0_","
+28 IF '$TEST
SET D0=ID1_","_D0_","
+29 SET FLAG=""
+30 IF DIC=9999999.18
SET D0=$GET(AGINSPTR)
IF DR=.21
SET FLAG="I"
+31 ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP
+32 NEW PIECE
+33 SET VDR=DR
+34 FOR PIECE=1:1
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:3
+35 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
+36 IF $PIECE(EXECUTE,";",PIECE)=""
Begin DoDot:4
+37 IF DIC=9999999.18
IF (DR=.01)
SET PLANPTR=$PIECE($GET(^AUPNMCR(ID0,11,ID1,0)),U,4)
+38 IF DIC=9999999.18
SET D0=$GET(PLANPTR)
+39 IF DIC=9000003.11
IF (DR=.05)
SET COVPTR=$PIECE($GET(^AUPNMCR(ID0,11,ID1,0)),U,11)
SET GRPPTR=$PIECE($GET(^AUPNMCR(ID0,11,ID1,0)),U,11)
+40 IF DIC=9000003.11
IF (DR=.04)
SET AGELP("INS")=$$GET1^DIQ(DIC,D0,DR,FLAG)
+41 SET DIC("S")="I $D(AGELP(""INS"")),$P(^(0),U,2)=AGELP(""INS"")"
+42 IF DIC=9999999.77
SET D0=$GET(GRPPTR)
+43 IF DIC=9999999.6519
Begin DoDot:5
+44 SET D0=$GET(COVPTR)
SET DT1=$ORDER(^AUTTPIC(37,19,"B",DT+.01),-1)
IF DT1=""
QUIT
+45 SET DT1=$ORDER(^AUTTPIC(37,19,"B",DT1,""))
+46 SET D0=DT1_","_D0_","
End DoDot:5
IF DT1=""
QUIT
+47 ;DISPLAY DATES AFTER STANDARD REG. SORT
IF DIC=9000003.11
IF (DR=.01)
DO GETDATES(ID0)
QUIT
+48 IF DIC=9999999.6519
IF ((DR=.23)!(DR=.24)!(DR=.25))
WRITE $JUSTIFY($$GET1^DIQ(DIC,D0,DR,FLAG),10,2)
+49 IF '$TEST
WRITE $$GET1^DIQ(DIC,D0,DR,FLAG)
End DoDot:4
+50 IF $PIECE(EXECUTE,";",PIECE)'=""
SET D0=$TRANSLATE(D0,",")
XECUTE $PIECE(EXECUTE,";",PIECE)
+51 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:3
+52 KILL PIECE,VDR
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+53 SET AG("N")=$LENGTH(AG("C"),"|")
+54 WRITE !,$GET(AGLINE("-"))
+55 KILL MYERRS,MYVARS
+56 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+57 SET MYVARS("DFN")=ID0
SET MYVARS("FINDCALL")="FINDPVT"
+58 SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+59 IF '$GET(NEWENTRY)
DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+60 DO VERIF^AGUTILS
+61 QUIT
GETDATES(ID0) ;EP - GET THE DTS USING LIST^DIC
+1 KILL RESULT,ERROR
+2 SET FLAGS=""
+3 SET FIELDS=";.01I;.02I;.03I"
+4 DO LIST^DIC(9000003.11,","_ID0_",",FIELDS,FLAGS,"*",,,,,,"RESULT","ERROR")
+5 DO DATESORT(.RESULT)
+6 QUIT
DATESORT(RESULT) ;EP - TAKE LIST RETURNED BY FILE^DIC AND SORT IT
+1 ;BASED ON SPECS
+2 NEW DATESORT,SPECSUB,EFFDT,ENDDT,CVG
+3 SET REC=0
+4 FOR
SET REC=$ORDER(RESULT("DILIST","ID",REC))
IF 'REC
QUIT
Begin DoDot:1
+5 SET ENDDT=RESULT("DILIST","ID",REC,.02)
+6 SET EFFDT=RESULT("DILIST","ID",REC,.01)
+7 SET CVG=RESULT("DILIST","ID",REC,.03)
+8 IF CVG'="D"
QUIT
+9 ;O=OPEN ENDED, T=TERM DATE
SET SPECSUB=$SELECT(ENDDT="":"O",1:"T")
+10 IF SPECSUB="O"
SET DATESORT(SPECSUB,EFFDT)=ENDDT_U_CVG
+11 IF '$TEST
SET DATESORT(SPECSUB,-ENDDT)=EFFDT_U_CVG
End DoDot:1
+12 ;GET DEFAULT EDIT DT. FIRST ONE IN DISP
SET DEFEDDT=$ORDER(DATESORT("O",""))
+13 IF DEFEDDT=""
SET DEFEDDT=$ORDER(DATESORT("T",""))
IF DEFEDDT'=""
SET DEFEDDT=$PIECE(DATESORT("T",DEFEDDT),U)
+14 DO SHOWNEW(.DATESORT)
+15 QUIT
SHOWNEW(DATESORT) ;EP
+1 NEW SPECSUB,DATE,DATE1,CVG,EFFDT,ENDDT,REC
+2 SET SPECSUB=""
+3 SET REC=1
+4 IF '$DATA(DATESORT("O"))
FOR
SET SPECSUB=$ORDER(DATESORT(SPECSUB))
IF SPECSUB=""
QUIT
DO ALLTERM
QUIT
+5 FOR
SET SPECSUB=$ORDER(DATESORT(SPECSUB))
IF SPECSUB=""
QUIT
Begin DoDot:1
+6 SET DATE=""
+7 FOR
SET DATE=$ORDER(DATESORT(SPECSUB,DATE))
IF DATE=""
QUIT
Begin DoDot:2
+8 SET DATE1=$PIECE(DATESORT(SPECSUB,DATE),U)
+9 SET CVG=$PIECE(DATESORT(SPECSUB,DATE),U,2)
+10 IF SPECSUB="O"
SET EFFDT=DATE
SET ENDDT=""
+11 IF '$TEST
SET EFFDT=DATE1
SET ENDDT=-DATE
+12 IF REC'=1
WRITE !
+13 SET Y=EFFDT
XECUTE ^DD("DD")
+14 WRITE ?3,Y
+15 ;W ?57,CVG
+16 SET Y=ENDDT
XECUTE ^DD("DD")
+17 WRITE ?40,Y
+18 WRITE ?79,$SELECT($$ISACTIVE^AGINS(EFFDT,ENDDT):"A",1:"I")
+19 IF $$ISACTIVE^AGINS(EFFDT,ENDDT)
SET DEFEDDT=EFFDT
+20 SET REC=REC+1
End DoDot:2
End DoDot:1
+21 QUIT
ALLTERM ;EP
+1 SET DATE=""
+2 FOR
SET DATE=$ORDER(DATESORT(SPECSUB,DATE),-1)
IF DATE=""
QUIT
Begin DoDot:1
+3 SET DATE1=$PIECE(DATESORT(SPECSUB,DATE),U)
+4 SET CVG=$PIECE(DATESORT(SPECSUB,DATE),U,2)
+5 IF SPECSUB="O"
SET EFFDT=DATE
SET ENDDT=""
+6 IF '$TEST
SET EFFDT=DATE1
SET ENDDT=-DATE
+7 IF REC'=1
WRITE !
+8 SET Y=EFFDT
XECUTE ^DD("DD")
+9 WRITE ?3,Y
+10 ;W ?57,CVG
+11 SET Y=ENDDT
XECUTE ^DD("DD")
+12 WRITE ?40,Y
+13 WRITE ?79,$SELECT($$ISACTIVE^AGINS(EFFDT,ENDDT):"A",1:"I")
+14 IF $$ISACTIVE^AGINS(EFFDT,ENDDT)
SET DEFEDDT=EFFDT
+15 SET REC=REC+1
End DoDot:1
+16 QUIT
WMSG ;EP - DISP THIS MSG IF THIS IS A NEW ENTRY
+1 WRITE !,"Editing Pharmacy Medicare Part D Eligibility record"
+2 QUIT
+3 ;;;;;;;;;;;;;;;;;;;;;;;;;;
+4 ; EDIT MEDICARE PART D FLDS
+5 ;;;;;;;;;;;;;;;;;;;;;;;;;;
EDITNAME(ID0,ID1) ;EP - EDIT MEDICARE NAME
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=".05R"
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITGEN(ID0,ID1) ;EP - EDIT GENDER
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=".08R"
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITID(ID0,ID1) ;EP - EDIT ID NUmber
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=".06R"
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITDOB(ID0,ID1) ;EP - EDIT DOB
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=".09R"
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITPC(ID0,ID1) ;EP - EDIT PERSON CODE
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=.07
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITCOV(ID0,ID1) ;EP - EDIT COVERAGE TYPE PTR
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=.12
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
ADDEFF(ID0) ;EP - ADD/EDIT NEW EFFECTIVE DATE
+1 KILL DIE,DIC,DA,DR
+2 ;IF DEFAULT USE IT
IF $GET(DEFEDDT)'=""
SET DIC("B")=DEFEDDT
+3 SET DA(1)=ID0
+4 SET DIC(0)="AE"
+5 SET DIC="^AUPNMCR("_DA(1)_",11,"
+6 SET DIC("S")="I $P($G(^(0)),U,3)=""D"""
+7 DO ^DIC
+8 IF +Y<0
QUIT
+9 KILL DIE,DIC,DA,DR
+10 DO EFFDT(ID0,+Y)
+11 QUIT
EFFDT(ID0,ID1) ;EP - EDIT EFFECTIVE DATE
+1 KILL DIE,DIC,DA,DR,DIDEL,ONLYONE,IEN
+2 IF $DATA(^XUSEC("AGZMGR",DUZ))
SET DIDEL=9000003.11
+3 SET IEN=0
FOR ONLYONE=1:1
SET IEN=$ORDER(^AUPNMCR(ID0,11,IEN))
IF 'IEN
QUIT
+4 SET DA=ID1
+5 SET DA(1)=ID0
+6 SET DIE="^AUPNMCR("_DA(1)_",11,"
+7 IF ONLYONE=1
Begin DoDot:1
+8 WRITE !!,"THERE IS ONLY ONE ELGIBILITY DATE RECORD FOR THIS PHARMACY ELIGIBILITY"
+9 WRITE !,"IF YOU DELETE THIS DATE THE ENTIRE PHARMACY DATA WILL BE DELETED FOR THIS"
+10 WRITE !,"PATIENT"
+11 WRITE !
+12 SET DR=".01R"
+13 SET DR(2,9000003.11)=".01R"
End DoDot:1
+14 IF '$TEST
SET DR=".01"
SET DR(2,9000003.11)=".01"
+15 DO ^DIE
+16 ;IF NO DA, ENTRY WAS DELETED
IF '$DATA(DA)
QUIT
+17 KILL DIE,DIC,DA,DR
+18 IF $DATA(^AUPNMCR(ID0,11,ID1,0))
DO EDITEXP(ID0,ID1)
+19 IF '$TEST
SET EXIT=1
+20 QUIT
EDITEXP(ID0,ID1) ;EP - EDIT EXPIRATION DATE
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=.02
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITGRP(ID0,ID1) ;EP - EDIT GROUP NAME
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=.11
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITPLAN(ID0,ID1) ;EP - EDIT PLAN
+1 KILL DIE,DIC,DA,DR
+2 SET DA(1)=ID0
+3 SET DA=ID1
+4 SET DIE="^AUPNMCR("_DA(1)_",11,"
+5 SET DR=".04R"
+6 DO ^DIE
+7 KILL DIE,DIC,DA,DR
+8 QUIT
EDITSTBN(COVPTR) ;EP - EDIT START BENEFIT
+1 KILL DIE,DIC,DA,DR
+2 WRITE !,"SPECIFICATIONS NOT YET PROVIDED!"
HANG 3
+3 KILL DIE,DIC,DA,DR
+4 QUIT
EDITDED(COVPTR) ;EP - EDIT DEDUCTIBLE
+1 KILL DIE,DIC,DA,DR
+2 WRITE !,"SPECIFICATIONS NOT YET PROVIDED!"
HANG 3
+3 KILL DIE,DIC,DA,DR
+4 QUIT
EDITCOP(COVPTR) ;EP - EDIT CO-PAY
+1 KILL DIE,DIC,DA,DR
+2 WRITE !,"SPECIFICATIONS NOT YET PROVIDED!"
HANG 3
+3 KILL DIE,DIC,DA,DR
+4 QUIT
+5 ;FIELD EDITS
+6 ; ****************************************************************
+7 ; ON LINES BELOW:
+8 ; U "^" DELIMITED
+9 ; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
+10 ; PIECE VAR DESC
+11 ; ----- -------- -----------------------------------------------
+12 ; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
+13 ; 2 CAPDENT POSITION ON LINE TO DISP CAP
+14 ; 3 DIC FILE OR SUBFILE #
+15 ; 4 DR FLD # - THESE CAN BE SEPARATED BY ";" THIS ALLOWS
+16 ; MULTIPLE FLDS TO BE PRINTED WITH THE SAME CAP AS IN
+17 ; 'CITY,STATE,ZIP'
+18 ; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE LINE
+19 ; 6 ITEMNUM ITEM # ASSIGNMENT. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
+20 ; FLD ON THE SCREEN
+21 ; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
+22 ;
+23 ; BAR "|" DELIMITED
+24 ; PIECE VAR DESC
+25 ; ----- -------- ----------------------------------------------
+26 ; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO.
+27 ; EXECUTED AFT FLD PRINT. IF MUTLIPLE FLDS ARE PRINTED
+28 ; THEN MULTIPLE EXECUTE CODES CAN BE SEPARATED BY ";".
+29 ; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS. USE TO SCREEN OUT
+30 ; PRINTING A FLD VALUE. FOR MULTIPLES SEPARATE BY ";"
+31 ; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
+32 ; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
+33 ; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
+34 ; FOR MULTIPLES SEPARATE BY ";"
+35 ;
+36 ;FIELDS BELOW DELETED PER ADRIAN 12/13/05
+37 ;Coverage Type^?3^9000003.11^.12^?49^^^||||
+38 ;Co-Pay.......^?3^9999999.6519^.25^?44^11^EDITCOP(COVPTR)||||
+39 ;Deductible...^?3^9999999.6519^.24^?44^10^EDITDED(COVPTR)^||||
+40 ;Begin Date...^?3^9999999.6519^.01^?49^^||||
+41 ;Start Benefit^?3^9999999.6519^.23^?44^9^EDITSTBN(COVPTR)^||||
+42 ;Ins. Type^?3^9999999.18^.21^?23^^^||||
1 ;
+1 ;;------------------MEDICARE PART D DATA-----------------------------------------
+2 ;;Medicare Name^?3^9000003.11^.05^!^1^EDITNAME(ID0,ID1)^||||W ?49,$C(124)
+3 ;;Gender^?3^9000003.11^.08^?49^4^EDITGEN(ID0,ID1)^||||
+4 ;;ID Number^?3^9000003.11^.06^!^2^EDITID(ID0,ID1)^||||W ?49,$C(124)
+5 ;;Date of Birth^?3^9000003.11^.09^?49^5^EDITDOB(ID0,ID1)^||||
+6 ;;Person Code^?3^9000003.11^.07^!^3^EDITPC(ID0,ID1)^||||
+7 ;;-ELIGIBILITY DATES--------------------------------------------------------------
+8 ;;-----Effective Date-----------------------Expire Date---------------------------
+9 ;;^?3^9000003.11^.01^!^6^ADDEFF(ID0)^||||
+10 ;;--------------------------------------------------------------------------------
+11 ;;Grp Name^?3^9000003.11^.11^!^7^EDITGRP(ID0,ID1)^||||
+12 ;;Grp Number^?3^9999999.77^.02^?45^^^||||
+13 ;;--------------------------------------------------------------------------------
+14 ;;^?3^9999999.18^.01^!^8^EDITPLAN(ID0,ID1)^||||
+15 ;;^?3^9999999.18^.02^!^^^||||
+16 ;;^?3^9999999.18^.03^!^^||||W ","
+17 ;;^?3^9999999.18^.04^?0^^||||W " "
+18 ;;^?3^9999999.18^.05^?0^^||||
+19 ;;^?3^9999999.18^.06^!^^||||
+20 ;;*END*
