AGEDPRV.m

AGEDPRV ;IHS/ASDS/TPF - PRIVATE INSURANCE PAGE A ;

 ;;7.1;PATIENT REGISTRATION;**1,2,3,8,11,12**;AUG 25, 2005;Build 1

 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX

 ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE

 ;

EN(ID0,ID1,NEWENTRY,AGSELECT,AGINSPTR,POLHPTR,COVPTR) ;EP - CALLED BY AG7

 K EXIT

 I '$G(POLHPTR),('NEWENTRY) D   I $G(EXIT) D CLEAN11(ID0,ID1) W !,"New entry not made" H 2 K EXIT D END Q

 .W !,"THIS RECORD HAS NO POLICY HOLDER PLEASE ENTER ONE NOW"

 .W !,"OR PRESS RETURN TO DELETE THIS RECORD!"

 .D ADDPOLH(ID0,AGINSPTR,.EXIT,.POLHPTR) I $G(POLHPTR)="" S EXIT=1 Q

 .;AG*7.1*2

 .S COMPIEN=ID0_",11,"_ID1_","_0

 .S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

 .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)

 .D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)

 .;END

 S AG("PG")="4PVTA"

 S ROUTID=$P($T(+1)," ")

 S CALLER="SCREEN"

 I NEWENTRY D  Q:$G(EXIT)!($G(POLHPTR)="")

 .D DRAW("")

 .D WMSG

 .D NEWENTRY(ID0) I +$G(Y)<0 S EXIT=1 W !,"Entry could not be created." H 2 D END Q

 .D ADDINS(ID0,AGINSPTR) I +$G(Y)<0 D CLEAN(ID0) S EXIT=1 W !,"New entry not made" H 2 D END Q

 .;D ADDPOLH(ID0,AGINSPTR,.EXIT,.POLHPTR) I $G(EXIT)!($G(POLHPTR)="") D CLEAN(ID0) W !,"New entry not made" H 2 D END Q

 .D ADDPOLH(ID0,AGINSPTR,.EXIT,.POLHPTR) I $G(EXIT)!($G(POLHPTR)="") D CLEAN11(ID0,ID1) D CLEAN(ID0) W !,"New entry not made" H 2 D END Q  ;AG*7.1*3 IM23566

 .S NEWENTRY=0

 .S COMPIEN=ID0_",11,"_ID1_","_0

 .S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

 S COMPIEN=ID0_",11,"_ID1_","_0

VAR ;

 Q:$G(POLHPTR)=""

 D DRAW(POLHPTR)

 I $D(AGSEENLY) K DIR S DIR(0)="E",DIR("A")="Enter Response" D ^DIR Q

 W !,AGLINE("EQ")

 K DIR

 S DIR("A")="ENTER ACTION (<E>dit Data,<A>dd Member,<D>elete Member,<V>iew/Edit PH Addr):"

 S DIR(0)="SAO^E:EDIT;A:ADD;D:DELETE;V:VIEW"

 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="A" D ADDMEMB^AGEDPRVP(ID0,POLHPTR,AGINSPTR,"A",.POLMEMBS) G VAR

 I Y="D" D  Q:$G(LASTDEL)!($G(DELALL))  G VAR

 .K LASTDEL,DELALL,CANCELED

 .D DELMEM^AGEDPRVP(POLHPTR,POLMCNT,.POLMEMBS,.LASTDEL,.DELALL,.CANCELED) K POLMEMBS

 .Q:$G(CANCELED)

 .I $G(LASTDEL) D

 ..W !!,"You have deleted the last member of this policy."

 ..W !,"Therefore the eligibility record has been deleted."

 ..H 3

 .I $G(DELALL) D

 ..W !!,"You have deleted the policy holder of this policy."

 ..W !,"Therefore the eligibility record has been deleted."

 ..H 3

 ;I Y="V" D EN^AGPHADDR($G(POLHPTR)) G VAR

 ;I Y="V" K DLOUT,DUOUT,DFOUT,DQOUT,DTOUT,DIROUT D EN^AGPHADDR($G(POLHPTR)) G VAR  ;AG*7.1*2 COULDN'T CHOOSE v) twice in a row if exiting View with "^^"

 I Y="V" K DLOUT,DUOUT,DFOUT,DQOUT,DTOUT,DIROUT D EN^AGPHADDR($G(POLHPTR))  ;AG*7.1*2 COULDN'T CHOOSE v) twice in a row if exiting View with "^^"

 ;I Y="E" D EDIT D:$G(EXIT) END Q:$G(EXIT)  G VAR

 I Y="E" D EDIT D:$G(EXIT) END Q:$G(EXIT)

 ;IM????? FIX ERRONEOUS MISSING ADDRESS ERROR

 ;IM????? NOT REPORTED. ERRORS NOT UPDATING WHEN CHANGING

 S COMPIEN=ID0_",11,"_ID1_","_0

 N GLO

 S GLO="^AUPNPRVT("_COMPIEN_")"

 S SHOWINAC='$$ISACTIVE^AGINS($P(@GLO,U,6),$P(@GLO,U,7))

 K GLO

 S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

 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)

 D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)

 ;END IM?????

 ;W !,"COMMAND "_Y_" UNKNOWN!" H 3

 G VAR

EDIT ;EP

 K DIR

 K DLOUT,DUOUT,DFOUT,DQOUT,DTOUT,DIROUT  ;AG*7.1*2

 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")>13 D EDITPOLM^AGEDPRVI(.POLMEMBS,CHOICES) Q

 .D @($P(AG("C"),"|",AG("SEL")))

 ;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

 D UPDATE1^AGED(DUZ(2),ID0,3,"")

 K AGI,AGY

 Q

CLEAN11(ID0,ID1) ;EP-

 K DIK,DA

 S DA(1)=ID0

 S DA=ID1

 S DIK="^AUPNPRVT("_DA(1)_",11," D ^DIK

 D CLEAN(ID0)

 Q

CLEAN(ID0) ;EP -

 I '$O(^AUPNPRVT(ID0,11,0)) D CLEANZER(ID0)

 Q

CLEANZER(ID0) ;EP - CLEAN ZERO NODE

 K DIK,DA

 S DIK="^AUPNPRVT(",DA=ID0 D ^DIK

 Q

END ;EP -

 K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y

 K ADA,WDA,ADT,WDT,REC,NEWENTRY,POLPTR,ID0,ID1,CALLER

 Q

DRAW(POLHPTR) ;EP -

 D HDR^AGEDPRVU(ID0)

 D GETAW(POLHPTR)

 Q

GETAW(POLHPTR) ;EP -

 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)

 . I $E(CAPTION)="-" W !,CAPTION Q

 . S DIC=$P(AGSCRN,U,3)

 . S DR=$P(AGSCRN,U,4)

 . S NEWLINE=$P(AGSCRN,U,5)

 . S CAPDENT=$P(AGSCRN,U,2)

 . S ITEMNUM=$P(AGSCRN,U,6)

 . S TAGCALL=$TR($P($P(AGSCRN,U,7),"|",1),"~",U)

 . S EXECUTE=$P(AGSCRN,"|",2)

 . S PREEXEC=$P(AGSCRN,"|",3)

 . S PRECAPEX=$P(AGSCRN,"|",4)

 . S POSTEXEC=$P(AGSCRN,"|",5)

 . S:TAGCALL'="" $P(AG("C"),"|",ITEMNUM)=TAGCALL

 . 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)_": ")

 .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"

 .. I DIC=9999999.18 S D0=$G(AGINSPTR)  ;IHS/OIT/NKD AG*7.1*12

 .. 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

 .... ;IHS/OIT/NKD AG*7.1*11 MU2 - REMOVED GENDER DISPLAY'S INTERNAL FLAG

 .... ;I DIC=9000003.1&(DR=.08) S FLAG="I"

 .... I DIC=9000003.1 S D0=POLHPTR S COVPTR=$$GET1^DIQ(DIC,D0,.05,"I") S NOPVTB=COVPTR=""

 .... I DIC=9000003.1,(DR=.19) W $$FMTE^XLFDT($$GET1^DIQ(DIC,D0,DR,"I"),5) Q

 .... I DIC=9000006.11,(DR=.08) S POLHPTR=$$GET1^DIQ(DIC,D0,DR,"I")  ;D POLMEM(POLHPTR,.POLMCNT,.POLMEMBS) Q  ;DISPLAY POLICY MEMBERS

 .... I DIC=9000003.1,(DR=.06) S GRPPTR=$$GET1^DIQ(DIC,D0,DR,"I")

 .... I DIC=9999999.77,(DR=.02) S D0=$G(GRPPTR)

 .... I DIC=9999999.65,(DR=.01) S D0=$G(COVPTR)

 .... I DIC=9000006.11,(DR=.15) W $$GET1^DIQ(DIC,D0,DR,"I") W:$$GET1^DIQ(DIC,D0,DR,"I")="Y" ?62,"Date:",$$FMTE^XLFDT($$GET1^DIQ(DIC,D0,.16,"I"),5) Q

 .... I (CAPTION[("Policy Member")) D POLMEM(POLHPTR,.POLMCNT,.POLMEMBS) Q  ;DISPLAY POLICY MEMBERS

 .... Q:DIC=9000003.1&(DR=.02)

 .... W $$GET1^DIQ(DIC,D0,DR,FLAG)

 .... S 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"),"|")+$G(POLMCNT)

 W !,$G(AGLINE("-"))

 ;S COMPIEN=ID0_",11,"_ID1_","_0

 ;S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

 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

WMSG ;EP -

 W !,"Entering new PRIVATE INSURANCE ELIGIBILITY record"

 Q

NEWENTRY(ID0) ;EP -

 K DIC,DIE,DR,DA,DO,DIR

 S X="`"_ID0

 S DIC(0)="L"

 S DIC="^AUPNPRVT("

 D ^DIC

 Q:+Y<0

 S ID0=+Y

 Q

ADDINS(ID0,AGINSPTR) ;EP -

 K DIC,DIE,DR,DA,DO,DIR,X,DINUM

 N DOUBLE

 S DOUBLE=0

 ;AG*7.1*2 IM20237

 I $D(^AUPNPRVT("I",AGINSPTR,ID0)) S DOUBLE=1 W *7,!!,"WARNING: If you proceed you will be ADDING an Insurer that the Patient already",!," has an Eligibility Record for!"

 K DTOUT,DUOUT,DIRUT

 I  W ! K DIR S DIR(0)="Y",DIR("A")="         Do you wish to proceed" D ^DIR K DIR W:Y=1 "   (OK, then proceed with caution)"

 I Y=0!$D(DTOUT)!$D(DIRUT)!(Y="^") S Y=-1 Q

 ;AG*7.1*2 IM21372

 ;S X="`"_AGINSPTR  AG*7.1*2 IM20237

 ;S DIC(0)="L"

 ;D ^DIC

 ;Q:+Y<0

 ;AG*7.1*2 END

 S X=AGINSPTR,DIC(0)="L"

 S DIC("S")="I +$G(Y)'=AGINSPTR,($P($G(^(1)),U,7)'=0)"

 S DA(1)=ID0

 S DIC="^AUPNPRVT("_DA(1)_",11,"

 D FILE^DICN  ;IM21372

 S ID1=+Y

 Q

ADDPOLH(PATPTR,AGINSPTR,EXIT,POLHPTR) ;EP - ADD POL HOLD

ADDPOLH2 N SAME,TARGET,REGISTER

 S (SAME,REGISTER,EXIT)=0

 W !!,"Enter the NAME of the POLICY HOLDER or the POLICY NUMBER if it already exists."

 W !?10,"(Enter 'SAME' if the PATIENT is the Policy Holder.)"

 K DIR W !

 S DIR(0)="FO^1:30",DIR("A")="Select POLICY HOLDER"

 ;AGEL("D")="^AUPN3PPH(",AGEL("D0")="QZEM",AGEL("DS")="I $P(^(0),U,3)=AGELP(""INS"")" I $D(AGELP("TYPE")),AGELP("TYPE")="MCD",$D(AG("NUM")) S AGEL("DS")=AGEL("DS")_",$P(^(0),U,4)=AG(""NUM"")"

 S DIR("?",1)="Enter Name of the person in whose name the account is carried or"

 S DIR("?",2)="the Policy Number if the Policy already exists."

 S DIR("?",3)="Enter SAME or SELF if the policy holder is the same as the patient."

 S DIR("?",4)=""

 S DIR("?")="(NOTE: Existing Policy Holders are displayed by entering ""??"")"

 S DIR("??")="^S X=""??"",DIC=""^AUPN3PPH("",DIC(0)=""QZEM"",DIC(""S"")=""I ($P($G(^(0)),U,3)=$G(AGINSPTR)),($P($G(^(0)),U,4)=$G(POLNUM))"" D ^DIC"

 D ^DIR

 ;IM?AG*7.1*2

 I Y=" " G ADDPOLH2

 I Y="/.,"!(Y="")!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S EXIT=1 Q

 ;S TARGET=X

 S (TARGET,FTARGET)=X  ;AG*7.1*3 IM23566

 I $$UPPER^AGUTILS(TARGET)="SAME"!($$UPPER^AGUTILS(TARGET)="SELF") S SAME=1 S REGISTER=1,TARGET=$P($G(^DPT(ID0,0)),U) W !!!! D PULLPATI(PATPTR,TARGET,PATPTR,SAME,.EXIT,ID1) Q  ;AG*7.1*2 RTN TOO BIG

 W !

 K RET,POLHPTR

 D PHLOOKUP(TARGET,.NEWPH,AGINSPTR) S REGISTER=0 I NEWPH>0 S POLHPTR=NEWPH D CONFIRM^AGEDPRV1 Q

 W !!,"No Hit Found in POLICY HOLDER file",!!,"Searching PATIENT file ...."

 K RET

 ;D PTLOOKUP(TARGET,.NEWPH) I $G(NEWPH)>0 S SAME=NEWPH=ID0 S REGISTER=1,TARGET=$P($G(^DPT(NEWPH,0)),U)  D CONFIRM Q:$G(EXIT)  W !!!! D PULLPATI(NEWPH,TARGET,ID0,SAME,.EXIT,ID1) Q

 D PTLOOKUP(TARGET,.NEWPH) I $G(NEWPH)>0 S SAME=NEWPH=ID0 S REGISTER=1,TARGET=$P($G(^DPT(NEWPH,0)),U)  D CONFIRM^AGEDPRV1 W !!!! S TMPEXIT=EXIT D:'$G(EXIT) PULLPATI(NEWPH,TARGET,ID0,SAME,.EXIT,ID1) Q:'$G(TMPEXIT)  ;AG*7.1*3 IM23566

 W !!,"No Hit Found in PATIENT File for ",$G(TARGET),"!" W !

 S TARGET=FTARGET,REGISTER=0  ;AG*7.1*3 IM23566

 W !!,TARGET," is a non registered patient"

 D CONFIRM^AGEDPRV1

 S EXIT=0  ;AG*7.1*3 IM23566

 Q

PHLOOKUP(X,NEWPH,AGINSPTR) ;EP -

 K DIC,DIE,DR,DA,DIR

 S DIC(0)="EM"

 S DIC="^AUPN3PPH("

 S DIC("S")="I $P(^(0),U,3)=$G(AGINSPTR)"

 S TEMPDFN=$G(DFN)

 D ^DIC

 S DFN=TEMPDFN

 S X=Y

 S NEWPH=+Y

 Q

PTLOOKUP(X,NEWPH) ;EP -

 K DIC,DIE,DR,DA,DIR

 S DIC(0)="EMFO"

 S DIC="^DPT("

 S TEMPDFN=$G(DFN)

 D ^DIC

 S DFN=TEMPDFN

 S X=Y

 S NEWPH=+Y

 Q

PULLPATI(NEWPH,X,PATPTR,SAME,EXIT,INSPTR) ;EP -

 N FILE,FIELD,FN

 S FN="FIELD"

 S FILE=2

 F FIELD=".01",".02",".03",".111",".114",".115",".116",".131" D

 .S FN=FN_"("_FILE_","_FIELD_")"

 .S @FN=$$GET1^DIQ(FILE,NEWPH,FIELD)

 .S FN="FIELD"

 S FILE=9000001

 F FIELD=".21",".19" D

 .S FN=FN_"("_FILE_","_FIELD_")"

 .S @FN=$$GET1^DIQ(FILE,NEWPH,FIELD,"I")

 .S FN="FIELD"

 ;D PUTPOLH(NEWPH,PATPTR,.POLHPTR,"NEW",.FIELD,SAME,.EXIT,INSPTR)

 D PUTPOLH^AGEDPRV1(NEWPH,PATPTR,.POLHPTR,"NEW",.FIELD,SAME,.EXIT,INSPTR)  ;AG*7.1*3

 Q

POLMEM(POLHPTR,POLMCNT,POLMEMBS) ;EP - DISPLAY POLICY MEMBERS

 N POLMEM,CNT,RECNO,POLMEM,POL0,POL11,RELATION,FROM,THRU

 K POLMEMBS

 I '$G(POLHPTR) W !,"THERE ARE NO POLICY MEMBERS FOR THIS ELIGIBLITY RECORD!" Q

 S POLMEM=""

 F CNT=1:1 S POLMEM=$O(^AUPNPRVT("C",POLHPTR,POLMEM)) Q:'POLMEM  D

 .S RECNO=0

 .F  S RECNO=$O(^AUPNPRVT("C",POLHPTR,POLMEM,RECNO)) Q:'RECNO  D

 ..S POL0=$G(^AUPNPRVT(POLMEM,0))

 ..S POL11=$G(^AUPNPRVT(POLMEM,11,RECNO,0))

 ..;AG*7.1*2 IM21986

 ..I POL11="" K ^AUPNPRVT("C",POLHPTR,POLMEM,RECNO) Q

 ..S PTPTR=$P(POL0,U)

 ..S RELATION=$P(POL11,U,5)

 ..S FROM=$P(POL11,U,6)

 ..S THRU=$P(POL11,U,7)

 ..I RELATION'="" S RELATION=$P($G(^AUTTRLSH(RELATION,0)),U) I RELATION="SELF" S POLMEMBS("SELF")=POLMEM

 ..W !,CNT+13,")"

 ..S POLMEMBS(CNT+13,POLMEM,RECNO)=""

 ..W:PTPTR'="" " "_$E($P($G(^DPT(PTPTR,0)),U),1,17)

 ..W ?22,$P(POL11,U,12)

 ..N AGPH                                                                       ;AG*7.1*8

 ..S AGPH=$P($G(^AUPNPRVT(POLMEM,11,RECNO,2)),U)

 ..I AGPH]"" W ?26,$E(AGPH,1,16)

 ..I AGPH="" D

 ...S AGPH=$P($G(^AUPNPRVT(POLMEM,11,RECNO,0)),U,8)

 ...W ?26,$E($P($G(^AUPN3PPH(AGPH,0)),U,4),1,16)

 ..W ?42,$P($G(^AUPNPAT(POLMEM,41,DUZ(2),0)),U,2)

 ..W ?50,$E(RELATION,1,9)

 ..S:FROM'="" FROM=$$FMTE^XLFDT(FROM,5)

 ..;W ?60,FROM

 ..W ?59,FROM  ;AG*7.1*2

 ..I THRU'="" S THRU=$$FMTE^XLFDT(THRU,5) W "-",THRU

 S POLMCNT=CNT-1

 Q

1 ;

 ;;Policy Holder.^?3^9000003.1^.01^!^1^EDITEM1~AGEDPRVP(ID0,POLHPTR)||||

 ;;^?3^9000003.1^.02^?0^^||||D NOTREG^AGEDPRV1(POLHPTR) W ?50,$C(124)

 ;;Gender^?3^9000003.1^.08^?50^5^EDITGEN~AGEDPRVP(POLHPTR,CALLER)

 ;;Policy or SSN.^?3^9000003.1^.04^!^2^EDITPOLN~AGEDPRVP(POLHPTR)||||W ?50,$C(124)

 ;;Date of Birth^?3^9000003.1^.19^?50^6^EDITDOB~AGEDPRVP(POLHPTR,CALLER)^

 ;;Effective Date^?3^9000003.1^.17^!^3^EFFDT~AGEDPRVP(POLHPTR)||||W ?40,$C(124)

 ;;PCP^?3^9000006.11^.14^?40^7^EDITPCP~AGEDPRVI(ID0,ID1,CALLER)|

 ;;Expire Date...^?3^9000003.1^.18^!^4^EDITEXP~AGEDPRVP(POLHPTR)||||W ?40,$C(124)

 ;;CD Name.....^?3^9000003.1^2^?40^8^EDCARDNM~AGEDPRVP(POLHPTR)

 ;;-HOLDER'S EMPLOYER INFO---------------------------------------------------------

 ;;Status........^?3^9000003.1^.15^!^9^EDITEMPL~AGEDPRVP(POLHPTR,"","",CALLER)||||W ?40,$C(124)

 ;;Employer^?3^9000003.1^.16^?41^10^EDITEMP~AGEDPRVP(POLHPTR,CALLER)^||

 ;;-INSURER INFORMATION------------------------------------------------------------

 ;;^?0^9000006.11^.01^!^^||||W ?40,$C(124)

 ;;Grp Name^?3^9000003.1^.06^?41^11^EDITGRP~AGEDPRVP(POLHPTR,CALLER)^||||

 ;;^?3^9999999.18^.02^!^^^||||W ?40,$C(124)

 ;;Grp Number^?3^9999999.77^.02^?45^^^|||

 ;;^?3^9999999.18^.03;.04;.05;^!^^^||||W ", ";W " ";W ?40,$C(124)

 ;;Coverage^?3^9999999.65^.01^?41^12^EDITCOV~AGEDPRVP(POLHPTR,CALLER)^||||W !|

 ;;^?3^9999999.18^.06^?0^^^||||

 ;;Ins. Type^?3^9999999.18^.211^?23^^^||||W ?40,$C(124)

 ;;CCopy^?3^9000006.11^.15^?41^13^EDITCC~AGEDPRVI(ID0,ID1,CALLER)^|||

 ;;----Policy Members----PC-----Member #------HRN-----Rel----------From/Thru-------

 ;;Policy Member^?3^9000006.11^.^?0^^^|||I CAPTION'[("Policy Member")|

 ;;*END*

AGEDPRV   ;IHS/ASDS/TPF - PRIVATE INSURANCE PAGE A ;

 +1       ;;7.1;PATIENT REGISTRATION;**1,2,3,8,11,12**;AUG 25, 2005;Build 1

 +2       ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX

 +3       ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE

 +4       ;

EN(ID0,ID1,NEWENTRY,AGSELECT,AGINSPTR,POLHPTR,COVPTR) ;EP - CALLED BY AG7

 +1        KILL EXIT

 +2        IF '$GET(POLHPTR)

               IF ('NEWENTRY)

                   Begin DoDot:1

 +3                    WRITE !,"THIS RECORD HAS NO POLICY HOLDER PLEASE ENTER ONE NOW"

 +4                    WRITE !,"OR PRESS RETURN TO DELETE THIS RECORD!"

 +5                    DO ADDPOLH(ID0,AGINSPTR,.EXIT,.POLHPTR)

                       IF $GET(POLHPTR)=""

                           SET EXIT=1

                           QUIT 

 +6       ;AG*7.1*2

 +7                    SET COMPIEN=ID0_",11,"_ID1_","_0

 +8                    SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

 +9                    KILL MYERRS,MYVARS

 +10                   DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)

 +11                   SET MYVARS("DFN")=ID0

                       SET MYVARS("FINDCALL")="FINDPVT"

 +12                   SET MYVARS("SELECTION")=$GET(AGSELECT)

                       SET MYVARS("SITE")=DUZ(2)

 +13                   DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)

 +14      ;END

                   End DoDot:1

                   IF $GET(EXIT)

                       DO CLEAN11(ID0,ID1)

                       WRITE !,"New entry not made"

                       HANG 2

                       KILL EXIT

                       DO END

                       QUIT 

 +15       SET AG("PG")="4PVTA"

 +16       SET ROUTID=$PIECE($TEXT(+1)," ")

 +17       SET CALLER="SCREEN"

 +18       IF NEWENTRY

               Begin DoDot:1

 +19               DO DRAW("")

 +20               DO WMSG

 +21               DO NEWENTRY(ID0)

                   IF +$GET(Y)<0

                       SET EXIT=1

                       WRITE !,"Entry could not be created."

                       HANG 2

                       DO END

                       QUIT 

 +22               DO ADDINS(ID0,AGINSPTR)

                   IF +$GET(Y)<0

                       DO CLEAN(ID0)

                       SET EXIT=1

                       WRITE !,"New entry not made"

                       HANG 2

                       DO END

                       QUIT 

 +23      ;D ADDPOLH(ID0,AGINSPTR,.EXIT,.POLHPTR) I $G(EXIT)!($G(POLHPTR)="") D CLEAN(ID0) W !,"New entry not made" H 2 D END Q

 +24      ;AG*7.1*3 IM23566

                   DO ADDPOLH(ID0,AGINSPTR,.EXIT,.POLHPTR)

                   IF $GET(EXIT)!($GET(POLHPTR)="")

                       DO CLEAN11(ID0,ID1)

                       DO CLEAN(ID0)

                       WRITE !,"New entry not made"

                       HANG 2

                       DO END

                       QUIT 

 +25               SET NEWENTRY=0

 +26               SET COMPIEN=ID0_",11,"_ID1_","_0

 +27               SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

               End DoDot:1

               IF $GET(EXIT)!($GET(POLHPTR)="")

                   QUIT 

 +28       SET COMPIEN=ID0_",11,"_ID1_","_0

VAR       ;

 +1        IF $GET(POLHPTR)=""

               QUIT 

 +2        DO DRAW(POLHPTR)

 +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        SET DIR("A")="ENTER ACTION (<E>dit Data,<A>dd Member,<D>elete Member,<V>iew/Edit PH Addr):"

 +7        SET DIR(0)="SAO^E:EDIT;A:ADD;D:DELETE;V:VIEW"

 +8        DO ^DIR

 +9        IF Y=$GET(AGOPT("ESCAPE"))

               QUIT 

 +10       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

 +11       IF Y=""

               DO CLEAN(ID0)

               QUIT 

 +12       IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               QUIT 

 +13       IF Y="A"

               DO ADDMEMB^AGEDPRVP(ID0,POLHPTR,AGINSPTR,"A",.POLMEMBS)

               GOTO VAR

 +14       IF Y="D"

               Begin DoDot:1

 +15               KILL LASTDEL,DELALL,CANCELED

 +16               DO DELMEM^AGEDPRVP(POLHPTR,POLMCNT,.POLMEMBS,.LASTDEL,.DELALL,.CANCELED)

                   KILL POLMEMBS

 +17               IF $GET(CANCELED)

                       QUIT 

 +18               IF $GET(LASTDEL)

                       Begin DoDot:2

 +19                       WRITE !!,"You have deleted the last member of this policy."

 +20                       WRITE !,"Therefore the eligibility record has been deleted."

 +21                       HANG 3

                       End DoDot:2

 +22               IF $GET(DELALL)

                       Begin DoDot:2

 +23                       WRITE !!,"You have deleted the policy holder of this policy."

 +24                       WRITE !,"Therefore the eligibility record has been deleted."

 +25                       HANG 3

                       End DoDot:2

               End DoDot:1

               IF $GET(LASTDEL)!($GET(DELALL))

                   QUIT 

               GOTO VAR

 +26      ;I Y="V" D EN^AGPHADDR($G(POLHPTR)) G VAR

 +27      ;I Y="V" K DLOUT,DUOUT,DFOUT,DQOUT,DTOUT,DIROUT D EN^AGPHADDR($G(POLHPTR)) G VAR  ;AG*7.1*2 COULDN'T CHOOSE v) twice in a row if exiting View with "^^"

 +28      ;AG*7.1*2 COULDN'T CHOOSE v) twice in a row if exiting View with "^^"

           IF Y="V"

               KILL DLOUT,DUOUT,DFOUT,DQOUT,DTOUT,DIROUT

               DO EN^AGPHADDR($GET(POLHPTR))

 +29      ;I Y="E" D EDIT D:$G(EXIT) END Q:$G(EXIT)  G VAR

 +30       IF Y="E"

               DO EDIT

               IF $GET(EXIT)

                   DO END

               IF $GET(EXIT)

                   QUIT 

 +31      ;IM????? FIX ERRONEOUS MISSING ADDRESS ERROR

 +32      ;IM????? NOT REPORTED. ERRORS NOT UPDATING WHEN CHANGING

 +33       SET COMPIEN=ID0_",11,"_ID1_","_0

 +34       NEW GLO

 +35       SET GLO="^AUPNPRVT("_COMPIEN_")"

 +36       SET SHOWINAC='$$ISACTIVE^AGINS($PIECE(@GLO,U,6),$PIECE(@GLO,U,7))

 +37       KILL GLO

 +38       SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)

 +39       KILL MYERRS,MYVARS

 +40       DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)

 +41       SET MYVARS("DFN")=ID0

           SET MYVARS("FINDCALL")="FINDPVT"

 +42       SET MYVARS("SELECTION")=$GET(AGSELECT)

           SET MYVARS("SITE")=DUZ(2)

 +43       DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)

 +44      ;END IM?????

 +45      ;W !,"COMMAND "_Y_" UNKNOWN!" H 3

 +46       GOTO VAR

EDIT      ;EP

 +1        KILL DIR

 +2       ;AG*7.1*2

           KILL DLOUT,DUOUT,DFOUT,DQOUT,DTOUT,DIROUT

 +3        SET DIR("A")="CHANGE which item? (1-"_$GET(AG("N"))_") NONE// "

 +4        SET DIR(0)="LO^1:"_$GET(AG("N"))

 +5        DO ^DIR

 +6        IF Y=$GET(AGOPT("ESCAPE"))

               SET EXIT=1

               QUIT 

 +7        SET CHOICES=Y

 +8        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 

 +9        IF Y=$GET(AGOPT("ESCAPE"))

               QUIT 

 +10       IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)

               QUIT 

 +11       IF $DATA(DFOUT)!$DATA(DTOUT)

               QUIT 

 +12       IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))

               WRITE !!,"You must enter a number from 1 to ",AG("N")

               HANG 2

               QUIT 

 +13       SET AGY=Y

 +14       FOR AGI=1:1

               SET AG("SEL")=+$PIECE(AGY,"|",AGI)

               IF AG("SEL")<1!(AG("SEL")>AG("N"))

                   QUIT 

               Begin DoDot:1

 +15               IF AG("SEL")>13

                       DO EDITPOLM^AGEDPRVI(.POLMEMBS,CHOICES)

                       QUIT 

 +16               DO @($PIECE(AG("C"),"|",AG("SEL")))

               End DoDot:1

 +17      ;S 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

 +20       DO UPDATE1^AGED(DUZ(2),ID0,3,"")

 +21       KILL AGI,AGY

 +22       QUIT 

CLEAN11(ID0,ID1) ;EP-

 +1        KILL DIK,DA

 +2        SET DA(1)=ID0

 +3        SET DA=ID1

 +4        SET DIK="^AUPNPRVT("_DA(1)_",11,"

           DO ^DIK

 +5        DO CLEAN(ID0)

 +6        QUIT 

CLEAN(ID0) ;EP -

 +1        IF '$ORDER(^AUPNPRVT(ID0,11,0))

               DO CLEANZER(ID0)

 +2        QUIT 

CLEANZER(ID0) ;EP - CLEAN ZERO NODE

 +1        KILL DIK,DA

 +2        SET DIK="^AUPNPRVT("

           SET DA=ID0

           DO ^DIK

 +3        QUIT 

END       ;EP -

 +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(POLHPTR) ;EP -

 +1        DO HDR^AGEDPRVU(ID0)

 +2        DO GETAW(POLHPTR)

 +3        QUIT 

GETAW(POLHPTR) ;EP -

 +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                SET CAPTION=$PIECE(AGSCRN,U)

 +6                IF $EXTRACT(CAPTION)="-"

                       WRITE !,CAPTION

                       QUIT 

 +7                SET DIC=$PIECE(AGSCRN,U,3)

 +8                SET DR=$PIECE(AGSCRN,U,4)

 +9                SET NEWLINE=$PIECE(AGSCRN,U,5)

 +10               SET CAPDENT=$PIECE(AGSCRN,U,2)

 +11               SET ITEMNUM=$PIECE(AGSCRN,U,6)

 +12               SET TAGCALL=$TRANSLATE($PIECE($PIECE(AGSCRN,U,7),"|",1),"~",U)

 +13               SET EXECUTE=$PIECE(AGSCRN,"|",2)

 +14               SET PREEXEC=$PIECE(AGSCRN,"|",3)

 +15               SET PRECAPEX=$PIECE(AGSCRN,"|",4)

 +16               SET POSTEXEC=$PIECE(AGSCRN,"|",5)