AGED4A ; IHS/ASDS/EFG - PAGE 4 - INSURANCE SUMMARY ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**1,2,7,11**;AUG 25, 2005;Build 1
;
;AG*7.1*7 - Modified code to allow the new page 10 to be called
;IHS/OIT/NKD AG*7.1*11 REMOVED SITE SPECIFIC CHECK
;
VAR ;PEP FOR PCC+
K CATPTR,CATHD,AGINS,AGCAT,AGNEWINS,AGTOUT
;S CATPTR="M"
S CATPTR="U" ;AG*7.1*2 AG/SD/TPF 6/26/2006 PG 34 TASK
S SHOWINAC=0 ;IHS/SD/TPF 6/27/2006 AG*7.1*2 ATTACHMENT VIII.1
D ^AGINS
I $D(AGPHFLAG) D ^AGINS
I $D(^AUPNICP("C",DFN)) D LOADCAT^AGCAT
VAR2 S AG("PG")="4",ROUTID=$P($T(+1)," "),AGANS=""
I '$D(AGSEENLY) D DRAW
K DLOUT
I $D(AGCAT) D LOADICP^AGCAT
I $D(AGSEENLY) D DRAW2
Q:$D(AGTOUT)!$D(DTOUT)
G END:'$D(AGANS)
S:AGANS="/.,"!(AGANS="^^") DFOUT=""
S:AGANS="" DLOUT=""
S:AGANS=U (DUOUT,Y)=""
S:AGANS?1"?".E!(AGANS[U) (DQOUT,Y)=""
Q:$D(DTOUT)!$D(DFOUT)
I (U_"P"_U_"p"_U)[(U_$E(AGANS,1)_U)&($P($G(^AUPNPAT(DFN,11)),U,12)'="") D
.S AG("ED")=+$P($E(AGANS,2,99),".")
.I AG("ED")<1!(AG("ED")>10) W *7,!!,"Use only pages 1 through 10." H 2 K AG("ED") S AG("ERR")="" ;AG*7.1*7
.I $D(AG("ED")) D
..I AG("ED")>0&(AG("ED")<11) D ;AG*7.1*7
...I AG("ED")=4 S AG("ED")="4A"
...I AG("ED")=5 S AG("ED")="BEA"
...I AG("ED")=6 S AG("ED")=13
...I AG("ED")=9 S AG("ED")="11A"
...I AG("ED")=8 S AG("ED")=11
...I AG("ED")=7 S AG("ED")=8
...I AG("ED")=10 S AG("ED")="10A" ;AG*7.1*7
I $E(AGANS,1)="P"&($P($G(^AUPNPAT(DFN,11)),U,12)="") W *7,!!,"Eligibility Status must be entered." H 2
I $D(AG("ED"))&'$D(AGXTERN) D LOADICP^AGCAT G @("^AGED"_AG("ED"))
G END:$D(DLOUT)!$D(DUOUT),VAR:$D(AG("ERR"))
K AGINS D ^AGINS
G VAR2
END K AG,DFOUT,DQOUT,DTOUT,DLOUT,DA,DIC,DIE,DR,AGSCRN,Y,CATHD,AGANS,AGTOUT,AGA,AGDT,AGB,CNT,MCDREC,RECPTR,SEL,ST,STPTR,AGADDINS,AGSEL,AGINSPTR,AGINSREC,AGMCDREC,CATPTR,COV,COVPTR
K CPTR,EFF,END,INS,INSPTR,PH,PHPTR,POLNUM,RECNO,RECORD,SEQEFDT,SEQFLG,SQDT,ROUTID
Q:$D(AGSEENLY)
K AGCAT,AGINS
Q:$D(AGXTERN)
Q:$D(DIROUT)
G ^AGED3:$D(DUOUT)
G ^AGEDBEA
CPROMPT ;EP - CALLED FROM AGED4A1
;K DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,CATPTR,DIR
K DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,DIR ;AG*7.1*2 AG/SD/TPF 6/26/2006 PAGE 37 OF TASK ORDER
I '$D(AGINS) W !,"This patient has NO insurers to sequence!" H 2 Q
;S DIR(0)="S^M:MEDICAL COVERAGE;D:DENTAL COVERAGE;O:OPTOMETRY COVERAGE;R:PHARMACY COVERAGE;P:MENTAL HEALTH COVERAGE;T:THIRD PARTY LIABILITY COVERAGE;W:WORKMAN'S COMP COVERAGE"
S DIR(0)="SO^M:MEDICAL COVERAGE;D:DENTAL COVERAGE;O:OPTOMETRY COVERAGE;R:PHARMACY COVERAGE;P:MENTAL HEALTH COVERAGE;T:THIRD PARTY LIABILITY COVERAGE;W:WORKMAN'S COMP COVERAGE;U:SUMMARY PAGE" ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
;S DIR(0)="SO^M:MEDICAL COVERAGE"_$S($D(AGCAT("M")):"*",1:"")
;S DIR(0)=DIR(0)_";D:DENTAL COVERAGE"_$S($D(AGCAT("D")):"*",1:"")
;S DIR(0)=DIR(0)_";O:OPTOMETRY COVERAGE"_$S($D(AGCAT("O")):"*",1:"")
;S DIR(0)=DIR(0)_";R:PHARMACY COVERAGE"_$S($D(AGCAT("R")):"*",1:"")
;S DIR(0)=DIR(0)_";P:MENTAL HEALTH COVERAGE"_$S($D(AGCAT("P")):"*",1:"")
;S DIR(0)=DIR(0)_";T:THIRD PARTY LIABILITY COVERAGE"_$S($D(AGCAT("T")):"*",1:"")
;S DIR(0)=DIR(0)_";W:WORKMAN'S COMP COVERAGE"_$S($D(AGCAT("T")):"*",1:"")
;S DIR(0)=DIR(0)_";U:SUMMARY PAGE"
;D ^DIR Q:$D(DUOUT)
D ^DIR Q:$D(DUOUT)!$D(DTOUT) ;IHS/SD/TPF AG*7.1*1 9/6/2005
I Y'="" D ;AG*7.1*2 AG/SD/TPF 6/26/2006 PAGE 37 OF TASK ORDER
.S X=Y,Y=$$UP^XLFSTR(X),CATPTR=Y
.S CATHD=$S(CATPTR="D":"DENTAL COVERAGE",CATPTR="O":"OPTOMETRY COVERAGE",CATPTR="R":"PHARMACY COVERAGE",CATPTR="P":"MENTAL HEALTH COVERAGE",CATPTR="T":"THIRD PARTY LIABILITY COVERAGE",CATPTR="W":"WORKMAN'S COMP COVERAGE",1:"MEDICAL COVERAGE")
E S CATPTR="U"
;S CATHD=$S(CATPTR="D":"DENTAL COVERAGE",CATPTR="O":"OPTOMETRY COVERAGE",CATPTR="R":"PHARMACY COVERAGE",CATPTR="P":"MENTAL HEALTH COVERAGE",CATPTR="T":"THIRD PARTY LIABILITY COVERAGE",CATPTR="W"
;:"WORKMAN'S COMP COVERAGE","M":"MEDICAL COVERAGE",1:"SUMMARY COVERAGE") ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
I $D(DIRUT),$$NEEDTOSQ^AGUTILS(DFN,DUZ(2)) W !!,"THIS PATIENT HAS NOT BEEN SEQUENCED. YOUR SITE REQUIRES SEQUENCING!! PLEASE CHOOSE A CATEGORY" G CPROMPT
;Q:CATPTR="S"!(CATPTR="") ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
;I AGANS="V" D VPROMPT^AGED4A1(CATPTR) Q ;VIEW PROMPT AG*7.1*2 IHS/SD/TPF 6/26/2006 PAGE 37
;I AGANS="T" D DISPCAT^AGED4A1 Q ;TO ACCOMODATE CHNAGE TO DEFAULT DISPLAY IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 2 PAGE 35
;I AGANS="S" D SPROMPT
Q
SPROMPT ;EP - ASK SEQUENCING QUESTIONS
S AG("PG")=4,ROUTID=$P($T(+1)," ")
D HEADING^AGED4A1
K DIR,DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,PRSEQ,Y,DIRUT
Q:$G(CATPTR)="" ;IHS/SD/TPF AG*7.1*1 10/24/2005
I '$D(AGCAT(CATPTR)) W !?16,"THIS PATIENT HAS NO INSURERS IN THIS CATEGORY."
;D DISPINS
D DISPINS^AGED4A1 ;AG*7.1*2 HAD TO MOVE BECAUSE RTN TOO LARGE FOR SAC
I '$D(AGINS) W !,"This patient has NO insurers to sequence!" H 2 Q
Q:AGANS=""!(AGANS=U)
K DIR,AGSEQ,PRSEQ,DASHSEQ,AGTST,AGMIN,AGMAX
S DIR(0)="L^1:"_MAX_":0"
D ^DIR
S X=Y,Y=$$UP^XLFSTR(X)
I $D(DIRUT) I $$NEEDTOSQ^AGUTILS(DFN,DUZ(2)) W !,"CANNOT EXIT WITHOUT SEQUENCING! YOUR SITE REQUIRES SEQUENCING!!" H 2 G SPROMPT
;Q:$D(DIRUT)!$D(DUOUT)
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) K CATHD S CATPTR="U" Q ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
S PRSEQ=Y
K DIR,DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,DIRUT
S DIR("A")="YOU ENTERED THE SEQUENCE "_PRSEQ_" IS THIS CORRECT (Y/N) "
S DIR(0)="Y"
D ^DIR
S X=Y,Y=$$UP^XLFSTR(X)
I $D(DIRUT) G SPROMPT
G SPROMPT:Y=0
K DIR,DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,DIRUT
S DIR("A")="WHAT IS THE EFFECTIVE DATE OF THIS PRIORITY SEQUENCE ? "
S DIR(0)="D"
D ^DIR
S SEQEFDT=Y
X ^DD("DD")
S ESEQEFDT=Y
S X=Y,Y=$$UP^XLFSTR(X)
G:$D(DIRUT) SPROMPT
;BEGIN NEW CODE ;AG*7.1*2 IM20494
I Y>DT D G:Y=0 SPROMPT
.W !!,"YOU ARE ADDING A EFFECTIVE SEQUENCING DATE OF "_ESEQEFDT
.K DIR
.S DIR(0)="Y"
.S DIR("A")="ARE YOU SURE YOU WANT TO ENTER THIS AS THE CORRECT DATE"
.S DIR("B")="N"
.D ^DIR
;END NEW CODE
K ESEQEFDT
K DIR
I SEQEFDT="" G SPROMPT
D BLDAGCAT^AGCAT,LOADICP^AGCAT
Q
DRAW ;EP
I $D(ADDCHK) D ADDMSG^AGED4A1
S ROUTID=$P($T(+1)," "),AG("PG")="4",DA=DFN
D HEADING^AGED4A1
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT,DIR
K DIRUT
;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 2 PAGE 35
;SUM SCR DEFAULT
;I $D(AGCAT) D
;.D LOADCAT^AGCAT
;.;D DISPCAT
;.D DISPCAT^AGED4A1 ;AG*7.1*1 SAC REQ RTN TOO LARGE
;.;I AGANS="T"!(AGANS="S") D CPROMPT
;.I $G(AGANS)="T"!($G(AGANS)="S") D CPROMPT
;I '$D(AGCAT) W !?20,"*** PATIENT HAS NO CATEGORIES SET UP ***" D
;.;D DISPLAYN
;.D DISPLAYN^AGED4A1 ;AG*7.1*1 SAC REQ TOO LRG
;.;I AGANS="T"!(AGANS="S") D CPROMPT
;.I $G(AGANS)="T"!($G(AGANS)="S") D CPROMPT
;S AGADDINS=AGANS
D DISPLAYN^AGED4A1
;I $G(AGANS)="T"!($G(AGANS)="S") D CPROMPT
;I $G(AGANS)="T"!($G(AGANS)="S")!($G(AGANS)="V") D CPROMPT ;AG*7.1*2 PAGE 37
;END NEW CODING AG*7.1*2
S AGADDINS=$G(AGANS)
;I $G(AGVIEWSQ) D DISPINS^AGED4A1 K AGVIEWSQ ;AG*7.1*2 CAME BACK FROM SEQ VIEWING SO NEED TO DISPLAY AGAIN
I $G(AGANS)="A" D ADDINS I $D(DUOUT) K DUOUT G DRAW
;I $G(AGANS)="E" D EDITINS I $D(DUOUT) K DUOUT G DRAW
I $G(AGANS)="E" D EDITINS^AGED4A01 I $D(DUOUT) K DUOUT G DRAW ;MOVE SUB RTN TO COMPLY WITH SAC RTN SIZE
I $G(AGANS)="REQSEQ" K AGANS G DRAW
Q
DRAW2 ;EP
S AG("PG")="4",ROUTID=$P($T(+1)," "),DA=DFN
D HEADING^AGED4A1
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT,DIR
;D DISPLAYN
D DISPLAYN^AGED4A1 ;AG*7.1*1 SAC REQ TOO LRG
I $G(AGANS)'=""&($G(AGANS)'=U)&($G(AGANS)'=U_U)&($G(AGANS)'="/.,") D
.;HANDLE RR AND MCR A & B
.I $D(AGINSNN(AGANS))=10 S AGINSREC=$G(AGINSNN(AGANS,1))
.E S AGINSREC=$G(AGINSNN(AGANS))
.S AGTYPE=$P(AGINSREC,U,10),AGELPTR=$P($P(AGINSREC,U,11),","),ISACTIVE=$P(AGINSREC,U,13)
.;AG/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
.I AGTYPE="MD" D EN^AGED4(AGINSREC) Q:$G(Y)=AGOPT("ESCAPE") D EN^AGED42(DFN,,0,AGINSREC) Q
.I AGTYPE="R"&($P(AGINSREC,U,2)'=1) D EN^AGED4(AGINSREC) Q:$G(Y)=AGOPT("ESCAPE") D EN^AGED42(DFN,,0,AGINSREC) Q
.I AGTYPE="R"&($P(AGINSREC,U,2)=1) D EN^AGED6(AGINSREC) Q:$G(Y)=AGOPT("ESCAPE") D EN^AGED62(DFN,,0,AGINSREC) Q
.I AGTYPE="D"!(AGTYPE="K") D
..S PARDFN=$P($P(AGINSREC,U,11),",")
..S PARDT=$P($P(AGINSREC,U,11),",",2)
..S NEWENTRY=0
..D EN^AGEDMCD(PARDFN,PARDT,NEWENTRY,AGINSREC)
.;I AGTYPE="P" S:$G(AGINSREC)'="" AGSELECT=AGINSREC D ^AGED7 K AGSELECT Q:$G(Y)=AGOPT("ESCAPE") I $G(AGINSPTR)'="",($P($G(^AUTNINS(AGINSPTR,2)),U)'="K"),$D(AGELP("PH")) S INSPTR=AGINSPTR D ^AGED7B
.I AGTYPE="P" D ;IHS/SD/TPF AG*7.1*1 USE NEW PRVT SCREEN RTNS
..S PARDFN=$P($P(AGINSREC,U,11),",")
..S PARREC=$P($P(AGINSREC,U,11),",",3)
..;S INSPTR=$P(AGINSREC,U,2)
..S AGINSPTR=$P(AGINSREC,U,2) ;IHS/SD/TPF 3/8/2006 AG*7.1*1
..S POLHPTR=$E($P(AGINSREC,U,7),2,99)
..S COVPTR=$P(AGINSREC,U,3)
..S:$G(AGINSREC)'="" AGSELECT=AGINSREC
..;D EN^AGEDPRV(PARDFN,PARREC,0,AGSELECT,INSPTR,POLHPTR,COVPTR)
..D EN^AGEDPRV(PARDFN,PARREC,0,AGSELECT,AGINSPTR,POLHPTR,COVPTR) ;IHS/SD/TPF 3/8/2006 AG*7.1*1
..K AGSELECT Q:$G(Y)=AGOPT("ESCAPE")
..;I ($P($G(^AUTNINS(INSPTR,2)),U)'="K") D EN^AGEDPRVB(PARDFN,PARREC,0,AGINSREC,INSPTR,POLHPTR,COVPTR)
..;I ($P($G(^AUTNINS(INSPTR,2)),U)'="K") D EN^AGEDPRVB(PARDFN,PARREC,0,AGINSREC,AGINSPTR,POLHPTR,COVPTR) ;IHS/SD/TPF 3/8/2006 AG*7.1*1
..I ($P($G(^AUTNINS(AGINSPTR,2)),U)'="K") D EN^AGEDPRVB(PARDFN,PARREC,0,AGINSREC,AGINSPTR,POLHPTR,COVPTR) ;IHS/SD/TPF 3/8/2006 AG*7.1*2
.I AGTYPE="T" D
..S PARDFN=$P($P(AGINSREC,U,11),",")
..S PARDT=$P($P(AGINSREC,U,11),",",2)
..S NEWENTRY=0
..D EN^AGEDTPL(PARDFN,PARDT,NEWENTRY,AGINSREC)
.I AGTYPE="W" D
..S PARDFN=$P($P(AGINSREC,U,11),",")
..S PARDT=$P($P(AGINSREC,U,11),",",2)
..S NEWENTRY=0
..D EN^AGEDWC(PARDFN,PARDT,NEWENTRY)
.I AGTYPE="G" D
..S PARDFN=$P($P(AGINSREC,U,11),",")
..;S PARDT=$P($P(AGINSREC,U,11),",",3)
..;S PARFIL=$P($P(AGINSREC,U,11),",",2)
..S PARDT=$P($P(AGINSREC,U,11),",",2)
..S PARFIL=$P($P(AGINSREC,U,11),",",3)
..S NEWENTRY=0
..D EN^AGEDGUAR(PARDFN,PARFIL,PARDT,NEWENTRY,AGINSREC)
..K PARDFN,PARFIL,PARDT,NEWENTRY
Q
ADDINS ;EP
N DIC,AGANS,AGMEANT
K ADDCHK,AGNEWINS
S DIC="^AUTNINS("
;IHS/OIT/NKD AG*7.1*11 REMOVED SITE SPECIFIC CHECK - START OLD CODE
;X ^%ZOSF("UCI")
;AG*7.1*2 IM21372 ;PER ADRIAN/SANDRA SITE SPECIFIC CHECK
;THE SPECIAL LOOKUP ROTUINE DOES NT WORK RIGHT AT WWH (TALEQUAH/WWHASTINGS)
;I $P(Y,",")="WWH" D
;.S DIC(0)="AEMQZI"
;.S DIC("W")="S ZIP=$P(^(0),U,5),ST=$P(^(0),U,2),CITY=$P(^(0),U,3) S:$P(^(0),U,4)'="""" STA=$P($G(^DIC(5,$P(^(0),U,4),0)),U,2) W ?40,ST,!?40,CITY,"", "",$G(STA),"" "",ZIP,!"
;E D
;.S DIC(0)="AEMQZ"
;.S DIC("S")="I $P($G(^(1)),U,7)'=0"
;END OLD CODE - START NEW CODE
S DIC(0)="AEMQZ"
S DIC("S")="I $P($G(^(1)),U,7)'=0"
;END NEW CODE
D ^DIC
I +Y<1 W !!,"Must enter an existing insurer" K DIC H 2 Q
S AGELP("INS")=+Y
K DIC
;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 ITEM 18
N NOADD
I $$ISMINOR^AGUTILS(DFN) D I NOADD K NOADD Q
.N INSNM,INSTYP
.S NOADD=0
.S INSNM=$P($G(^AUTNINS(AGELP("INS"),0)),U)
.S INSTYP=$P($G(^AUTNINS(AGELP("INS"),2)),U)
.I INSNM[("MEDICARE")!(INSNM[("RAILROAD RETIREMENT")) S NOADD=1
.I INSTYP="R" S NOADD=1
.I AGELP("INS")=1 S NOADD=1
.;I NOADD W !,"A MINOR CANNOT BE THE POLICY HOLDER FOR "_$G(INSNM) H 3 Q
.Q:'NOADD
.K DIR
.S DIR(0)="Y"
.S DIR("A")="A MINOR CANNOT BE THE POLICY HOLDER FOR "_$G(INSNM)_"..DO YOU WISH TO ADD ENTRY?//" ;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20637
.S DIR("B")="N"
.D ^DIR
.I Y S NOADD=0
K NOADD
;END NEW CODE
S AGNEWINS=""
S AGTYPE=$P($G(^AUTNINS(AGELP("INS"),2)),U)
;AG/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
I AGTYPE="MD" D G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ADDINS
.K DIR,DIE,DR,DIC
.W !!,"YOU HAVE CHOSEN A MEDICARE PART D INSURER."
.S DIR("A")="IS THIS FOR MEDICARE OR RAILROAD RETIREMENT?"
.S DIR("B")="MEDICARE"
.S DIR(0)="SBO^M:MEDICARE;R:RAILROAD"
.D ^DIR
.S AGMEANT=Y
;NEXT TWO LINES FOR AG*7.1*1 ITEM 2
I AGTYPE="MD",(AGMEANT="M") S AGELDT=0 D EN^AGED4("") Q:'$O(^AUPNMCR(DFN,11,0)) D EN^AGED42(DFN,,0) Q
I AGTYPE="MD",(AGMEANT="R") S AGELDT=0 D EN^AGED6("") Q:'$O(^AUPNRRE(DFN,11,0)) D EN^AGED62(DFN,,0) Q
I AGTYPE="R"&(AGELP("INS")'=1) S AGELDT=0 D EN^AGED4("") Q:'$O(^AUPNMCR(DFN,11,0)) D EN^AGED42(DFN,,0) Q
I AGTYPE="R"&(AGELP("INS")=1) S AGELDT=0 D EN^AGED6("") Q:'$O(^AUPNRRE(DFN,11,0)) D EN^AGED62(DFN,,0) Q
I AGTYPE="K",$$GET1^DIQ(9999999.18,AGELP("INS"),.38,"I")="P" S AGTYPE="P",AGKIDS=""
I AGTYPE="D"!(AGTYPE="K") D Q
.S PARDFN=""
.S PARDT=""
.S NEWENTRY=1
.D EN^AGEDMCD(PARDFN,PARDT,NEWENTRY)
I AGTYPE="T" D Q
.S PARDFN=""
.S PARDT=""
.S NEWENTRY=1
.S AGSELECT=""
.D EN^AGEDTPL(PARDFN,PARDT,NEWENTRY,AGSELECT,AGELP("INS"))
.K PARDFN,PARDT,NEWENTRY,AGSELECT
I AGTYPE="W" D Q
.S PARDFN=""
.S PARDT=""
.S NEWENTRY=1
.D EN^AGEDWC(PARDFN,PARDT,NEWENTRY)
.K PARDFN,PARDT,NEWENTRY,AGSELECT
I AGTYPE="G" D Q
.S PARDFN=""
.S PARDT=""
.S PARFIL=""
.S NEWENTRY=1
.D EN^AGEDGUAR(PARDFN,PARFIL,PARDT,NEWENTRY)
.K PARDFN,PARFIL,PARDT,NEWENTRY
;IHS/SD/TPF AG*7.1*1 REPLACE OLD GOTO CODE FOR PRVT INS/ EDIT SCREENS
;D ^AGED7 ;OLD PRVT INSURANCE SCREEN
D
.S ID0=DFN
.;S INSPTR=$G(AGELP("INS"))
.S AGINSPTR=$G(AGELP("INS")) ;IHS/SD/TPF 3/8/2006 AG*7.1*1
.S POLHPTR=""
.D EN^AGEDPRV(ID0,.ID1,1,"",AGINSPTR,.POLHPTR,.COVPTR)
.Q:$G(ID1)=""
.K PARDFN,PARFIL,PARINS,NEWENTRY,AGSELECT
.Q:$G(Y)=AGOPT("ESCAPE")
.I '$O(^AUPNPRVT(ID0,11,0)) Q
.;D:$G(INSPTR)'=""&('$D(AGKIDS))&($G(POLHPTR)'="")&($G(COVPTR)'="") EN^AGEDPRVB(ID0,ID1,1,"",$G(INSPTR),$G(POLHPTR),$G(COVPTR))
.D:$G(AGINSPTR)'=""&('$D(AGKIDS))&($G(POLHPTR)'="")&($G(COVPTR)'="") EN^AGEDPRVB(ID0,ID1,1,"",$G(AGINSPTR),$G(POLHPTR),$G(COVPTR))
;Q:$G(Y)=AGOPT("ESCAPE")
;I '$O(^AUPNPRVT(DFN,11,0)) Q
;D:$G(INSPTR)'=""&('$D(AGKIDS))&($G(AGELP("PH"))'="") ^AGED7B
;END IHS/SD/TPF AG*7.1*1
K AGINS
D ^AGINS
Q
AGED4A ; IHS/ASDS/EFG - PAGE 4 - INSURANCE SUMMARY ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**1,2,7,11**;AUG 25, 2005;Build 1
+2 ;
+3 ;AG*7.1*7 - Modified code to allow the new page 10 to be called
+4 ;IHS/OIT/NKD AG*7.1*11 REMOVED SITE SPECIFIC CHECK
+5 ;
VAR ;PEP FOR PCC+
+1 KILL CATPTR,CATHD,AGINS,AGCAT,AGNEWINS,AGTOUT
+2 ;S CATPTR="M"
+3 ;AG*7.1*2 AG/SD/TPF 6/26/2006 PG 34 TASK
SET CATPTR="U"
+4 ;IHS/SD/TPF 6/27/2006 AG*7.1*2 ATTACHMENT VIII.1
SET SHOWINAC=0
+5 DO ^AGINS
+6 IF $DATA(AGPHFLAG)
DO ^AGINS
+7 IF $DATA(^AUPNICP("C",DFN))
DO LOADCAT^AGCAT
VAR2 SET AG("PG")="4"
SET ROUTID=$PIECE($TEXT(+1)," ")
SET AGANS=""
+1 IF '$DATA(AGSEENLY)
DO DRAW
+2 KILL DLOUT
+3 IF $DATA(AGCAT)
DO LOADICP^AGCAT
+4 IF $DATA(AGSEENLY)
DO DRAW2
+5 IF $DATA(AGTOUT)!$DATA(DTOUT)
QUIT
+6 IF '$DATA(AGANS)
GOTO END
+7 IF AGANS="/.,"!(AGANS="^^")
SET DFOUT=""
+8 IF AGANS=""
SET DLOUT=""
+9 IF AGANS=U
SET (DUOUT,Y)=""
+10 IF AGANS?1"?".E!(AGANS[U)
SET (DQOUT,Y)=""
+11 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+12 IF (U_"P"_U_"p"_U)[(U_$EXTRACT(AGANS,1)_U)&($PIECE($GET(^AUPNPAT(DFN,11)),U,12)'="")
Begin DoDot:1
+13 SET AG("ED")=+$PIECE($EXTRACT(AGANS,2,99),".")
+14 ;AG*7.1*7
IF AG("ED")<1!(AG("ED")>10)
WRITE *7,!!,"Use only pages 1 through 10."
HANG 2
KILL AG("ED")
SET AG("ERR")=""
+15 IF $DATA(AG("ED"))
Begin DoDot:2
+16 ;AG*7.1*7
IF AG("ED")>0&(AG("ED")<11)
Begin DoDot:3
+17 IF AG("ED")=4
SET AG("ED")="4A"
+18 IF AG("ED")=5
SET AG("ED")="BEA"
+19 IF AG("ED")=6
SET AG("ED")=13
+20 IF AG("ED")=9
SET AG("ED")="11A"
+21 IF AG("ED")=8
SET AG("ED")=11
+22 IF AG("ED")=7
SET AG("ED")=8
+23 ;AG*7.1*7
IF AG("ED")=10
SET AG("ED")="10A"
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF $EXTRACT(AGANS,1)="P"&($PIECE($GET(^AUPNPAT(DFN,11)),U,12)="")
WRITE *7,!!,"Eligibility Status must be entered."
HANG 2
+25 IF $DATA(AG("ED"))&'$DATA(AGXTERN)
DO LOADICP^AGCAT
GOTO @("^AGED"_AG("ED"))
+26 IF $DATA(DLOUT)!$DATA(DUOUT)
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+27 KILL AGINS
DO ^AGINS
+28 GOTO VAR2
END KILL AG,DFOUT,DQOUT,DTOUT,DLOUT,DA,DIC,DIE,DR,AGSCRN,Y,CATHD,AGANS,AGTOUT,AGA,AGDT,AGB,CNT,MCDREC,RECPTR,SEL,ST,STPTR,AGADDINS,AGSEL,AGINSPTR,AGINSREC,AGMCDREC,CATPTR,COV,COVPTR
+1 KILL CPTR,EFF,END,INS,INSPTR,PH,PHPTR,POLNUM,RECNO,RECORD,SEQEFDT,SEQFLG,SQDT,ROUTID
+2 IF $DATA(AGSEENLY)
QUIT
+3 KILL AGCAT,AGINS
+4 IF $DATA(AGXTERN)
QUIT
+5 IF $DATA(DIROUT)
QUIT
+6 IF $DATA(DUOUT)
GOTO ^AGED3
+7 GOTO ^AGEDBEA
CPROMPT ;EP - CALLED FROM AGED4A1
+1 ;K DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,CATPTR,DIR
+2 ;AG*7.1*2 AG/SD/TPF 6/26/2006 PAGE 37 OF TASK ORDER
KILL DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,DIR
+3 IF '$DATA(AGINS)
WRITE !,"This patient has NO insurers to sequence!"
HANG 2
QUIT
+4 ;S DIR(0)="S^M:MEDICAL COVERAGE;D:DENTAL COVERAGE;O:OPTOMETRY COVERAGE;R:PHARMACY COVERAGE;P:MENTAL HEALTH COVERAGE;T:THIRD PARTY LIABILITY COVERAGE;W:WORKMAN'S COMP COVERAGE"
+5 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
SET DIR(0)="SO^M:MEDICAL COVERAGE;D:DENTAL COVERAGE;O:OPTOMETRY COVERAGE;R:PHARMACY COVERAGE;P:MENTAL HEALTH COVERAGE;T:THIRD PARTY LIABILITY COVERAGE;W:WORKMAN'S COMP COVERAGE;U:SUMMARY PAGE"
+6 ;S DIR(0)="SO^M:MEDICAL COVERAGE"_$S($D(AGCAT("M")):"*",1:"")
+7 ;S DIR(0)=DIR(0)_";D:DENTAL COVERAGE"_$S($D(AGCAT("D")):"*",1:"")
+8 ;S DIR(0)=DIR(0)_";O:OPTOMETRY COVERAGE"_$S($D(AGCAT("O")):"*",1:"")
+9 ;S DIR(0)=DIR(0)_";R:PHARMACY COVERAGE"_$S($D(AGCAT("R")):"*",1:"")
+10 ;S DIR(0)=DIR(0)_";P:MENTAL HEALTH COVERAGE"_$S($D(AGCAT("P")):"*",1:"")
+11 ;S DIR(0)=DIR(0)_";T:THIRD PARTY LIABILITY COVERAGE"_$S($D(AGCAT("T")):"*",1:"")
+12 ;S DIR(0)=DIR(0)_";W:WORKMAN'S COMP COVERAGE"_$S($D(AGCAT("T")):"*",1:"")
+13 ;S DIR(0)=DIR(0)_";U:SUMMARY PAGE"
+14 ;D ^DIR Q:$D(DUOUT)
+15 ;IHS/SD/TPF AG*7.1*1 9/6/2005
DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+16 ;AG*7.1*2 AG/SD/TPF 6/26/2006 PAGE 37 OF TASK ORDER
IF Y'=""
Begin DoDot:1
+17 SET X=Y
SET Y=$$UP^XLFSTR(X)
SET CATPTR=Y
+18 SET CATHD=$SELECT(CATPTR="D":"DENTAL COVERAGE",CATPTR="O":"OPTOMETRY COVERAGE",CATPTR="R":"PHARMACY COVERAGE",CATPTR="P":"MENTAL HEALTH COVERAGE",CATPTR="T":"THIRD PARTY LIABILITY COVERAGE",CATPTR="W":"WORKMAN'S COMP COVERAGE",1:"MEDICA
L COVERAGE")
End DoDot:1
+19 IF '$TEST
SET CATPTR="U"
+20 ;S CATHD=$S(CATPTR="D":"DENTAL COVERAGE",CATPTR="O":"OPTOMETRY COVERAGE",CATPTR="R":"PHARMACY COVERAGE",CATPTR="P":"MENTAL HEALTH COVERAGE",CATPTR="T":"THIRD PARTY LIABILITY COVERAGE",CATPTR="W"
+21 ;:"WORKMAN'S COMP COVERAGE","M":"MEDICAL COVERAGE",1:"SUMMARY COVERAGE") ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
+22 IF $DATA(DIRUT)
IF $$NEEDTOSQ^AGUTILS(DFN,DUZ(2))
WRITE !!,"THIS PATIENT HAS NOT BEEN SEQUENCED. YOUR SITE REQUIRES SEQUENCING!! PLEASE CHOOSE A CATEGORY"
GOTO CPROMPT
+23 ;Q:CATPTR="S"!(CATPTR="") ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
+24 ;I AGANS="V" D VPROMPT^AGED4A1(CATPTR) Q ;VIEW PROMPT AG*7.1*2 IHS/SD/TPF 6/26/2006 PAGE 37
+25 ;I AGANS="T" D DISPCAT^AGED4A1 Q ;TO ACCOMODATE CHNAGE TO DEFAULT DISPLAY IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 2 PAGE 35
+26 ;I AGANS="S" D SPROMPT
+27 QUIT
SPROMPT ;EP - ASK SEQUENCING QUESTIONS
+1 SET AG("PG")=4
SET ROUTID=$PIECE($TEXT(+1)," ")
+2 DO HEADING^AGED4A1
+3 KILL DIR,DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,PRSEQ,Y,DIRUT
+4 ;IHS/SD/TPF AG*7.1*1 10/24/2005
IF $GET(CATPTR)=""
QUIT
+5 IF '$DATA(AGCAT(CATPTR))
WRITE !?16,"THIS PATIENT HAS NO INSURERS IN THIS CATEGORY."
+6 ;D DISPINS
+7 ;AG*7.1*2 HAD TO MOVE BECAUSE RTN TOO LARGE FOR SAC
DO DISPINS^AGED4A1
+8 IF '$DATA(AGINS)
WRITE !,"This patient has NO insurers to sequence!"
HANG 2
QUIT
+9 IF AGANS=""!(AGANS=U)
QUIT
+10 KILL DIR,AGSEQ,PRSEQ,DASHSEQ,AGTST,AGMIN,AGMAX
+11 SET DIR(0)="L^1:"_MAX_":0"
+12 DO ^DIR
+13 SET X=Y
SET Y=$$UP^XLFSTR(X)
+14 IF $DATA(DIRUT)
IF $$NEEDTOSQ^AGUTILS(DFN,DUZ(2))
WRITE !,"CANNOT EXIT WITHOUT SEQUENCING! YOUR SITE REQUIRES SEQUENCING!!"
HANG 2
GOTO SPROMPT
+15 ;Q:$D(DIRUT)!$D(DUOUT)
+16 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 5 PAGE 35
IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
KILL CATHD
SET CATPTR="U"
QUIT
+17 SET PRSEQ=Y
+18 KILL DIR,DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,DIRUT
+19 SET DIR("A")="YOU ENTERED THE SEQUENCE "_PRSEQ_" IS THIS CORRECT (Y/N) "
+20 SET DIR(0)="Y"
+21 DO ^DIR
+22 SET X=Y
SET Y=$$UP^XLFSTR(X)
+23 IF $DATA(DIRUT)
GOTO SPROMPT
+24 IF Y=0
GOTO SPROMPT
+25 KILL DIR,DFOUT,DTOUT,DUOUT,DLOUT,DIROUT,DIRUT
+26 SET DIR("A")="WHAT IS THE EFFECTIVE DATE OF THIS PRIORITY SEQUENCE ? "
+27 SET DIR(0)="D"
+28 DO ^DIR
+29 SET SEQEFDT=Y
+30 XECUTE ^DD("DD")
+31 SET ESEQEFDT=Y
+32 SET X=Y
SET Y=$$UP^XLFSTR(X)
+33 IF $DATA(DIRUT)
GOTO SPROMPT
+34 ;BEGIN NEW CODE ;AG*7.1*2 IM20494
+35 IF Y>DT
Begin DoDot:1
+36 WRITE !!,"YOU ARE ADDING A EFFECTIVE SEQUENCING DATE OF "_ESEQEFDT
+37 KILL DIR
+38 SET DIR(0)="Y"
+39 SET DIR("A")="ARE YOU SURE YOU WANT TO ENTER THIS AS THE CORRECT DATE"
+40 SET DIR("B")="N"
+41 DO ^DIR
End DoDot:1
IF Y=0
GOTO SPROMPT
+42 ;END NEW CODE
+43 KILL ESEQEFDT
+44 KILL DIR
+45 IF SEQEFDT=""
GOTO SPROMPT
+46 DO BLDAGCAT^AGCAT
DO LOADICP^AGCAT
+47 QUIT
DRAW ;EP
+1 IF $DATA(ADDCHK)
DO ADDMSG^AGED4A1
+2 SET ROUTID=$PIECE($TEXT(+1)," ")
SET AG("PG")="4"
SET DA=DFN
+3 DO HEADING^AGED4A1
+4 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT,DIR
+5 KILL DIRUT
+6 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 2 PAGE 35
+7 ;SUM SCR DEFAULT
+8 ;I $D(AGCAT) D
+9 ;.D LOADCAT^AGCAT
+10 ;.;D DISPCAT
+11 ;.D DISPCAT^AGED4A1 ;AG*7.1*1 SAC REQ RTN TOO LARGE
+12 ;.;I AGANS="T"!(AGANS="S") D CPROMPT
+13 ;.I $G(AGANS)="T"!($G(AGANS)="S") D CPROMPT
+14 ;I '$D(AGCAT) W !?20,"*** PATIENT HAS NO CATEGORIES SET UP ***" D
+15 ;.;D DISPLAYN
+16 ;.D DISPLAYN^AGED4A1 ;AG*7.1*1 SAC REQ TOO LRG
+17 ;.;I AGANS="T"!(AGANS="S") D CPROMPT
+18 ;.I $G(AGANS)="T"!($G(AGANS)="S") D CPROMPT
+19 ;S AGADDINS=AGANS
+20 DO DISPLAYN^AGED4A1
+21 ;I $G(AGANS)="T"!($G(AGANS)="S") D CPROMPT
+22 ;I $G(AGANS)="T"!($G(AGANS)="S")!($G(AGANS)="V") D CPROMPT ;AG*7.1*2 PAGE 37
+23 ;END NEW CODING AG*7.1*2
+24 SET AGADDINS=$GET(AGANS)
+25 ;I $G(AGVIEWSQ) D DISPINS^AGED4A1 K AGVIEWSQ ;AG*7.1*2 CAME BACK FROM SEQ VIEWING SO NEED TO DISPLAY AGAIN
+26 IF $GET(AGANS)="A"
DO ADDINS
IF $DATA(DUOUT)
KILL DUOUT
GOTO DRAW
+27 ;I $G(AGANS)="E" D EDITINS I $D(DUOUT) K DUOUT G DRAW
+28 ;MOVE SUB RTN TO COMPLY WITH SAC RTN SIZE
IF $GET(AGANS)="E"
DO EDITINS^AGED4A01
IF $DATA(DUOUT)
KILL DUOUT
GOTO DRAW
+29 IF $GET(AGANS)="REQSEQ"
KILL AGANS
GOTO DRAW
+30 QUIT
DRAW2 ;EP
+1 SET AG("PG")="4"
SET ROUTID=$PIECE($TEXT(+1)," ")
SET DA=DFN
+2 DO HEADING^AGED4A1
+3 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT,AG("ED"),AG("ERR"),DIROUT,DIR
+4 ;D DISPLAYN
+5 ;AG*7.1*1 SAC REQ TOO LRG
DO DISPLAYN^AGED4A1
+6 IF $GET(AGANS)'=""&($GET(AGANS)'=U)&($GET(AGANS)'=U_U)&($GET(AGANS)'="/.,")
Begin DoDot:1
+7 ;HANDLE RR AND MCR A & B
+8 IF $DATA(AGINSNN(AGANS))=10
SET AGINSREC=$GET(AGINSNN(AGANS,1))
+9 IF '$TEST
SET AGINSREC=$GET(AGINSNN(AGANS))
+10 SET AGTYPE=$PIECE(AGINSREC,U,10)
SET AGELPTR=$PIECE($PIECE(AGINSREC,U,11),",")
SET ISACTIVE=$PIECE(AGINSREC,U,13)
+11 ;AG/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
+12 IF AGTYPE="MD"
DO EN^AGED4(AGINSREC)
IF $GET(Y)=AGOPT("ESCAPE")
QUIT
DO EN^AGED42(DFN,,0,AGINSREC)
QUIT
+13 IF AGTYPE="R"&($PIECE(AGINSREC,U,2)'=1)
DO EN^AGED4(AGINSREC)
IF $GET(Y)=AGOPT("ESCAPE")
QUIT
DO EN^AGED42(DFN,,0,AGINSREC)
QUIT
+14 IF AGTYPE="R"&($PIECE(AGINSREC,U,2)=1)
DO EN^AGED6(AGINSREC)
IF $GET(Y)=AGOPT("ESCAPE")
QUIT
DO EN^AGED62(DFN,,0,AGINSREC)
QUIT
+15 IF AGTYPE="D"!(AGTYPE="K")
Begin DoDot:2
+16 SET PARDFN=$PIECE($PIECE(AGINSREC,U,11),",")
+17 SET PARDT=$PIECE($PIECE(AGINSREC,U,11),",",2)
+18 SET NEWENTRY=0
+19 DO EN^AGEDMCD(PARDFN,PARDT,NEWENTRY,AGINSREC)
End DoDot:2
+20 ;I AGTYPE="P" S:$G(AGINSREC)'="" AGSELECT=AGINSREC D ^AGED7 K AGSELECT Q:$G(Y)=AGOPT("ESCAPE") I $G(AGINSPTR)'="",($P($G(^AUTNINS(AGINSPTR,2)),U)'="K"),$D(AGELP("PH")) S INSPTR=AGINSPTR D ^AGED7B
+21 ;IHS/SD/TPF AG*7.1*1 USE NEW PRVT SCREEN RTNS
IF AGTYPE="P"
Begin DoDot:2
+22 SET PARDFN=$PIECE($PIECE(AGINSREC,U,11),",")
+23 SET PARREC=$PIECE($PIECE(AGINSREC,U,11),",",3)
+24 ;S INSPTR=$P(AGINSREC,U,2)
+25 ;IHS/SD/TPF 3/8/2006 AG*7.1*1
SET AGINSPTR=$PIECE(AGINSREC,U,2)
+26 SET POLHPTR=$EXTRACT($PIECE(AGINSREC,U,7),2,99)
+27 SET COVPTR=$PIECE(AGINSREC,U,3)
+28 IF $GET(AGINSREC)'=""
SET AGSELECT=AGINSREC
+29 ;D EN^AGEDPRV(PARDFN,PARREC,0,AGSELECT,INSPTR,POLHPTR,COVPTR)
+30 ;IHS/SD/TPF 3/8/2006 AG*7.1*1
DO EN^AGEDPRV(PARDFN,PARREC,0,AGSELECT,AGINSPTR,POLHPTR,COVPTR)
+31 KILL AGSELECT
IF $GET(Y)=AGOPT("ESCAPE")
QUIT
+32 ;I ($P($G(^AUTNINS(INSPTR,2)),U)'="K") D EN^AGEDPRVB(PARDFN,PARREC,0,AGINSREC,INSPTR,POLHPTR,COVPTR)
+33 ;I ($P($G(^AUTNINS(INSPTR,2)),U)'="K") D EN^AGEDPRVB(PARDFN,PARREC,0,AGINSREC,AGINSPTR,POLHPTR,COVPTR) ;IHS/SD/TPF 3/8/2006 AG*7.1*1
+34 ;IHS/SD/TPF 3/8/2006 AG*7.1*2
IF ($PIECE($GET(^AUTNINS(AGINSPTR,2)),U)'="K")
DO EN^AGEDPRVB(PARDFN,PARREC,0,AGINSREC,AGINSPTR,POLHPTR,COVPTR)
End DoDot:2
+35 IF AGTYPE="T"
Begin DoDot:2
+36 SET PARDFN=$PIECE($PIECE(AGINSREC,U,11),",")
+37 SET PARDT=$PIECE($PIECE(AGINSREC,U,11),",",2)
+38 SET NEWENTRY=0
+39 DO EN^AGEDTPL(PARDFN,PARDT,NEWENTRY,AGINSREC)
End DoDot:2
+40 IF AGTYPE="W"
Begin DoDot:2
+41 SET PARDFN=$PIECE($PIECE(AGINSREC,U,11),",")
+42 SET PARDT=$PIECE($PIECE(AGINSREC,U,11),",",2)
+43 SET NEWENTRY=0
+44 DO EN^AGEDWC(PARDFN,PARDT,NEWENTRY)
End DoDot:2
+45 IF AGTYPE="G"
Begin DoDot:2
+46 SET PARDFN=$PIECE($PIECE(AGINSREC,U,11),",")
+47 ;S PARDT=$P($P(AGINSREC,U,11),",",3)
+48 ;S PARFIL=$P($P(AGINSREC,U,11),",",2)
+49 SET PARDT=$PIECE($PIECE(AGINSREC,U,11),",",2)
+50 SET PARFIL=$PIECE($PIECE(AGINSREC,U,11),",",3)
+51 SET NEWENTRY=0
+52 DO EN^AGEDGUAR(PARDFN,PARFIL,PARDT,NEWENTRY,AGINSREC)
+53 KILL PARDFN,PARFIL,PARDT,NEWENTRY
End DoDot:2
End DoDot:1
+54 QUIT
ADDINS ;EP
+1 NEW DIC,AGANS,AGMEANT
+2 KILL ADDCHK,AGNEWINS
+3 SET DIC="^AUTNINS("
+4 ;IHS/OIT/NKD AG*7.1*11 REMOVED SITE SPECIFIC CHECK - START OLD CODE
+5 ;X ^%ZOSF("UCI")
+6 ;AG*7.1*2 IM21372 ;PER ADRIAN/SANDRA SITE SPECIFIC CHECK
+7 ;THE SPECIAL LOOKUP ROTUINE DOES NT WORK RIGHT AT WWH (TALEQUAH/WWHASTINGS)
+8 ;I $P(Y,",")="WWH" D
+9 ;.S DIC(0)="AEMQZI"
+10 ;.S DIC("W")="S ZIP=$P(^(0),U,5),ST=$P(^(0),U,2),CITY=$P(^(0),U,3) S:$P(^(0),U,4)'="""" STA=$P($G(^DIC(5,$P(^(0),U,4),0)),U,2) W ?40,ST,!?40,CITY,"", "",$G(STA),"" "",ZIP,!"
+11 ;E D
+12 ;.S DIC(0)="AEMQZ"
+13 ;.S DIC("S")="I $P($G(^(1)),U,7)'=0"
+14 ;END OLD CODE - START NEW CODE
+15 SET DIC(0)="AEMQZ"
+16 SET DIC("S")="I $P($G(^(1)),U,7)'=0"
+17 ;END NEW CODE
+18 DO ^DIC
+19 IF +Y<1
WRITE !!,"Must enter an existing insurer"
KILL DIC
HANG 2
QUIT
+20 SET AGELP("INS")=+Y
+21 KILL DIC
+22 ;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 ITEM 18
+23 NEW NOADD
+24 IF $$ISMINOR^AGUTILS(DFN)
Begin DoDot:1
+25 NEW INSNM,INSTYP
+26 SET NOADD=0
+27 SET INSNM=$PIECE($GET(^AUTNINS(AGELP("INS"),0)),U)
+28 SET INSTYP=$PIECE($GET(^AUTNINS(AGELP("INS"),2)),U)
+29 IF INSNM[("MEDICARE")!(INSNM[("RAILROAD RETIREMENT"))
SET NOADD=1
+30 IF INSTYP="R"
SET NOADD=1
+31 IF AGELP("INS")=1
SET NOADD=1
+32 ;I NOADD W !,"A MINOR CANNOT BE THE POLICY HOLDER FOR "_$G(INSNM) H 3 Q
+33 IF 'NOADD
QUIT
+34 KILL DIR
+35 SET DIR(0)="Y"
+36 ;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20637
SET DIR("A")="A MINOR CANNOT BE THE POLICY HOLDER FOR "_$GET(INSNM)_"..DO YOU WISH TO ADD ENTRY?//"
+37 SET DIR("B")="N"
+38 DO ^DIR
+39 IF Y
SET NOADD=0
End DoDot:1
IF NOADD
KILL NOADD
QUIT
+40 KILL NOADD
+41 ;END NEW CODE
+42 SET AGNEWINS=""
+43 SET AGTYPE=$PIECE($GET(^AUTNINS(AGELP("INS"),2)),U)
+44 ;AG/SD/TPF 12/20/2005 AG*7.1*1 ITEM 2
+45 IF AGTYPE="MD"
Begin DoDot:1
+46 KILL DIR,DIE,DR,DIC
+47 WRITE !!,"YOU HAVE CHOSEN A MEDICARE PART D INSURER."
+48 SET DIR("A")="IS THIS FOR MEDICARE OR RAILROAD RETIREMENT?"
+49 SET DIR("B")="MEDICARE"
+50 SET DIR(0)="SBO^M:MEDICARE;R:RAILROAD"
+51 DO ^DIR
+52 SET AGMEANT=Y
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ADDINS
+53 ;NEXT TWO LINES FOR AG*7.1*1 ITEM 2
+54 IF AGTYPE="MD"
IF (AGMEANT="M")
SET AGELDT=0
DO EN^AGED4("")
IF '$ORDER(^AUPNMCR(DFN,11,0))
QUIT
DO EN^AGED42(DFN,,0)
QUIT
+55 IF AGTYPE="MD"
IF (AGMEANT="R")
SET AGELDT=0
DO EN^AGED6("")
IF '$ORDER(^AUPNRRE(DFN,11,0))
QUIT
DO EN^AGED62(DFN,,0)
QUIT
+56 IF AGTYPE="R"&(AGELP("INS")'=1)
SET AGELDT=0
DO EN^AGED4("")
IF '$ORDER(^AUPNMCR(DFN,11,0))
QUIT
DO EN^AGED42(DFN,,0)
QUIT
+57 IF AGTYPE="R"&(AGELP("INS")=1)
SET AGELDT=0
DO EN^AGED6("")
IF '$ORDER(^AUPNRRE(DFN,11,0))
QUIT
DO EN^AGED62(DFN,,0)
QUIT
+58 IF AGTYPE="K"
IF $$GET1^DIQ(9999999.18,AGELP("INS"),.38,"I")="P"
SET AGTYPE="P"
SET AGKIDS=""
+59 IF AGTYPE="D"!(AGTYPE="K")
Begin DoDot:1
+60 SET PARDFN=""
+61 SET PARDT=""
+62 SET NEWENTRY=1
+63 DO EN^AGEDMCD(PARDFN,PARDT,NEWENTRY)
End DoDot:1
QUIT
+64 IF AGTYPE="T"
Begin DoDot:1
+65 SET PARDFN=""
+66 SET PARDT=""
+67 SET NEWENTRY=1
+68 SET AGSELECT=""
+69 DO EN^AGEDTPL(PARDFN,PARDT,NEWENTRY,AGSELECT,AGELP("INS"))
+70 KILL PARDFN,PARDT,NEWENTRY,AGSELECT
End DoDot:1
QUIT
+71 IF AGTYPE="W"
Begin DoDot:1
+72 SET PARDFN=""
+73 SET PARDT=""
+74 SET NEWENTRY=1
+75 DO EN^AGEDWC(PARDFN,PARDT,NEWENTRY)
+76 KILL PARDFN,PARDT,NEWENTRY,AGSELECT
End DoDot:1
QUIT
+77 IF AGTYPE="G"
Begin DoDot:1
+78 SET PARDFN=""
+79 SET PARDT=""
+80 SET PARFIL=""
+81 SET NEWENTRY=1
+82 DO EN^AGEDGUAR(PARDFN,PARFIL,PARDT,NEWENTRY)
+83 KILL PARDFN,PARFIL,PARDT,NEWENTRY
End DoDot:1
QUIT
+84 ;IHS/SD/TPF AG*7.1*1 REPLACE OLD GOTO CODE FOR PRVT INS/ EDIT SCREENS
+85 ;D ^AGED7 ;OLD PRVT INSURANCE SCREEN
+86 Begin DoDot:1
+87 SET ID0=DFN
+88 ;S INSPTR=$G(AGELP("INS"))
+89 ;IHS/SD/TPF 3/8/2006 AG*7.1*1
SET AGINSPTR=$GET(AGELP("INS"))
+90 SET POLHPTR=""
+91 DO EN^AGEDPRV(ID0,.ID1,1,"",AGINSPTR,.POLHPTR,.COVPTR)
+92 IF $GET(ID1)=""
QUIT
+93 KILL PARDFN,PARFIL,PARINS,NEWENTRY,AGSELECT
+94 IF $GET(Y)=AGOPT("ESCAPE")
QUIT
+95 IF '$ORDER(^AUPNPRVT(ID0,11,0))
QUIT
+96 ;D:$G(INSPTR)'=""&('$D(AGKIDS))&($G(POLHPTR)'="")&($G(COVPTR)'="") EN^AGEDPRVB(ID0,ID1,1,"",$G(INSPTR),$G(POLHPTR),$G(COVPTR))
+97 IF $GET(AGINSPTR)'=""&('$DATA(AGKIDS))&($GET(POLHPTR)'="")&($GET(COVPTR)'="")
DO EN^AGEDPRVB(ID0,ID1,1,"",$GET(AGINSPTR),$GET(POLHPTR),$GET(COVPTR))
End DoDot:1
+98 ;Q:$G(Y)=AGOPT("ESCAPE")
+99 ;I '$O(^AUPNPRVT(DFN,11,0)) Q
+100 ;D:$G(INSPTR)'=""&('$D(AGKIDS))&($G(AGELP("PH"))'="") ^AGED7B
+101 ;END IHS/SD/TPF AG*7.1*1
+102 KILL AGINS
+103 DO ^AGINS
+104 QUIT
