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)
+17 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 'NEWENTRY
Begin DoDot:2
+24 SET D0=ID0
+25 IF DIC'["."
SET D0=D0_","
+26 IF '$TEST
SET D0=ID1_","_D0_","
+27 SET FLAG=""
+28 ;I DIC=9999999.18 S D0=$G(AGINSPTR) I DR=.21 S FLAG="I"
+29 ;IHS/OIT/NKD AG*7.1*12
IF DIC=9999999.18
SET D0=$GET(AGINSPTR)
+30 NEW PIECE
+31 SET VDR=DR
+32 FOR PIECE=1:1
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:3
+33 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
+34 IF $PIECE(EXECUTE,";",PIECE)=""
Begin DoDot:4
+35 ;IHS/OIT/NKD AG*7.1*11 MU2 - REMOVED GENDER DISPLAY'S INTERNAL FLAG
+36 ;I DIC=9000003.1&(DR=.08) S FLAG="I"
+37 IF DIC=9000003.1
SET D0=POLHPTR
SET COVPTR=$$GET1^DIQ(DIC,D0,.05,"I")
SET NOPVTB=COVPTR=""
+38 IF DIC=9000003.1
IF (DR=.19)
WRITE $$FMTE^XLFDT($$GET1^DIQ(DIC,D0,DR,"I"),5)
QUIT
+39 ;D POLMEM(POLHPTR,.POLMCNT,.POLMEMBS) Q ;DISPLAY POLICY MEMBERS
IF DIC=9000006.11
IF (DR=.08)
SET POLHPTR=$$GET1^DIQ(DIC,D0,DR,"I")
+40 IF DIC=9000003.1
IF (DR=.06)
SET GRPPTR=$$GET1^DIQ(DIC,D0,DR,"I")
+41 IF DIC=9999999.77
IF (DR=.02)
SET D0=$GET(GRPPTR)
+42 IF DIC=9999999.65
IF (DR=.01)
SET D0=$GET(COVPTR)
+43 IF DIC=9000006.11
IF (DR=.15)
WRITE $$GET1^DIQ(DIC,D0,DR,"I")
IF $$GET1^DIQ(DIC,D0,DR,"I")="Y"
WRITE ?62,"Date:",$$FMTE^XLFDT($$GET1^DIQ(DIC,D0,.16,"I"),5)
QUIT
+44 ;DISPLAY POLICY MEMBERS
IF (CAPTION[("Policy Member"))
DO POLMEM(POLHPTR,.POLMCNT,.POLMEMBS)
QUIT
+45 IF DIC=9000003.1&(DR=.02)
QUIT
+46 WRITE $$GET1^DIQ(DIC,D0,DR,FLAG)
+47 SET FLAG=""
End DoDot:4
+48 IF $PIECE(EXECUTE,";",PIECE)'=""
SET D0=$TRANSLATE(D0,",")
XECUTE $PIECE(EXECUTE,";",PIECE)
+49 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:3
+50 KILL PIECE,VDR
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+51 SET AG("N")=$LENGTH(AG("C"),"|")+$GET(POLMCNT)
+52 WRITE !,$GET(AGLINE("-"))
+53 ;S COMPIEN=ID0_",11,"_ID1_","_0
+54 ;S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGINSPTR)
+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
WMSG ;EP -
+1 WRITE !,"Entering new PRIVATE INSURANCE ELIGIBILITY record"
+2 QUIT
NEWENTRY(ID0) ;EP -
+1 KILL DIC,DIE,DR,DA,DO,DIR
+2 SET X="`"_ID0
+3 SET DIC(0)="L"
+4 SET DIC="^AUPNPRVT("
+5 DO ^DIC
+6 IF +Y<0
QUIT
+7 SET ID0=+Y
+8 QUIT
ADDINS(ID0,AGINSPTR) ;EP -
+1 KILL DIC,DIE,DR,DA,DO,DIR,X,DINUM
+2 NEW DOUBLE
+3 SET DOUBLE=0
+4 ;AG*7.1*2 IM20237
+5 IF $DATA(^AUPNPRVT("I",AGINSPTR,ID0))
SET DOUBLE=1
WRITE *7,!!,"WARNING: If you proceed you will be ADDING an Insurer that the Patient already",!," has an Eligibility Record for!"
+6 KILL DTOUT,DUOUT,DIRUT
+7 IF $TEST
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")=" Do you wish to proceed"
DO ^DIR
KILL DIR
IF Y=1
WRITE " (OK, then proceed with caution)"
+8 IF Y=0!$DATA(DTOUT)!$DATA(DIRUT)!(Y="^")
SET Y=-1
QUIT
+9 ;AG*7.1*2 IM21372
+10 ;S X="`"_AGINSPTR AG*7.1*2 IM20237
+11 ;S DIC(0)="L"
+12 ;D ^DIC
+13 ;Q:+Y<0
+14 ;AG*7.1*2 END
+15 SET X=AGINSPTR
SET DIC(0)="L"
+16 SET DIC("S")="I +$G(Y)'=AGINSPTR,($P($G(^(1)),U,7)'=0)"
+17 SET DA(1)=ID0
+18 SET DIC="^AUPNPRVT("_DA(1)_",11,"
+19 ;IM21372
DO FILE^DICN
+20 SET ID1=+Y
+21 QUIT
ADDPOLH(PATPTR,AGINSPTR,EXIT,POLHPTR) ;EP - ADD POL HOLD
ADDPOLH2 NEW SAME,TARGET,REGISTER
+1 SET (SAME,REGISTER,EXIT)=0
+2 WRITE !!,"Enter the NAME of the POLICY HOLDER or the POLICY NUMBER if it already exists."
+3 WRITE !?10,"(Enter 'SAME' if the PATIENT is the Policy Holder.)"
+4 KILL DIR
WRITE !
+5 SET DIR(0)="FO^1:30"
SET DIR("A")="Select POLICY HOLDER"
+6 ;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"")"
+7 SET DIR("?",1)="Enter Name of the person in whose name the account is carried or"
+8 SET DIR("?",2)="the Policy Number if the Policy already exists."
+9 SET DIR("?",3)="Enter SAME or SELF if the policy holder is the same as the patient."
+10 SET DIR("?",4)=""
+11 SET DIR("?")="(NOTE: Existing Policy Holders are displayed by entering ""??"")"
+12 SET 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"
+13 DO ^DIR
+14 ;IM?AG*7.1*2
+15 IF Y=" "
GOTO ADDPOLH2
+16 IF Y="/.,"!(Y="")!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET EXIT=1
QUIT
+17 ;S TARGET=X
+18 ;AG*7.1*3 IM23566
SET (TARGET,FTARGET)=X
+19 ;AG*7.1*2 RTN TOO BIG
IF $$UPPER^AGUTILS(TARGET)="SAME"!($$UPPER^AGUTILS(TARGET)="SELF")
SET SAME=1
SET REGISTER=1
SET TARGET=$PIECE($GET(^DPT(ID0,0)),U)
WRITE !!!!
DO PULLPATI(PATPTR,TARGET,PATPTR,SAME,.EXIT,ID1)
QUIT
+20 WRITE !
+21 KILL RET,POLHPTR
+22 DO PHLOOKUP(TARGET,.NEWPH,AGINSPTR)
SET REGISTER=0
IF NEWPH>0
SET POLHPTR=NEWPH
DO CONFIRM^AGEDPRV1
QUIT
+23 WRITE !!,"No Hit Found in POLICY HOLDER file",!!,"Searching PATIENT file ...."
+24 KILL RET
+25 ;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
+26 ;AG*7.1*3 IM23566
DO PTLOOKUP(TARGET,.NEWPH)
IF $GET(NEWPH)>0
SET SAME=NEWPH=ID0
SET REGISTER=1
SET TARGET=$PIECE($GET(^DPT(NEWPH,0)),U)
DO CONFIRM^AGEDPRV1
WRITE !!!!
SET TMPEXIT=EXIT
IF '$GET(EXIT)
DO PULLPATI(NEWPH,TARGET,ID0,SAME,.EXIT,ID1)
IF '$GET(TMPEXIT)
QUIT
+27 WRITE !!,"No Hit Found in PATIENT File for ",$GET(TARGET),"!"
WRITE !
+28 ;AG*7.1*3 IM23566
SET TARGET=FTARGET
SET REGISTER=0
+29 WRITE !!,TARGET," is a non registered patient"
+30 DO CONFIRM^AGEDPRV1
+31 ;AG*7.1*3 IM23566
SET EXIT=0
+32 QUIT
PHLOOKUP(X,NEWPH,AGINSPTR) ;EP -
+1 KILL DIC,DIE,DR,DA,DIR
+2 SET DIC(0)="EM"
+3 SET DIC="^AUPN3PPH("
+4 SET DIC("S")="I $P(^(0),U,3)=$G(AGINSPTR)"
+5 SET TEMPDFN=$GET(DFN)
+6 DO ^DIC
+7 SET DFN=TEMPDFN
+8 SET X=Y
+9 SET NEWPH=+Y
+10 QUIT
PTLOOKUP(X,NEWPH) ;EP -
+1 KILL DIC,DIE,DR,DA,DIR
+2 SET DIC(0)="EMFO"
+3 SET DIC="^DPT("
+4 SET TEMPDFN=$GET(DFN)
+5 DO ^DIC
+6 SET DFN=TEMPDFN
+7 SET X=Y
+8 SET NEWPH=+Y
+9 QUIT
PULLPATI(NEWPH,X,PATPTR,SAME,EXIT,INSPTR) ;EP -
+1 NEW FILE,FIELD,FN
+2 SET FN="FIELD"
+3 SET FILE=2
+4 FOR FIELD=".01",".02",".03",".111",".114",".115",".116",".131"
Begin DoDot:1
+5 SET FN=FN_"("_FILE_","_FIELD_")"
+6 SET @FN=$$GET1^DIQ(FILE,NEWPH,FIELD)
+7 SET FN="FIELD"
End DoDot:1
+8 SET FILE=9000001
+9 FOR FIELD=".21",".19"
Begin DoDot:1
+10 SET FN=FN_"("_FILE_","_FIELD_")"
+11 SET @FN=$$GET1^DIQ(FILE,NEWPH,FIELD,"I")
+12 SET FN="FIELD"
End DoDot:1
+13 ;D PUTPOLH(NEWPH,PATPTR,.POLHPTR,"NEW",.FIELD,SAME,.EXIT,INSPTR)
+14 ;AG*7.1*3
DO PUTPOLH^AGEDPRV1(NEWPH,PATPTR,.POLHPTR,"NEW",.FIELD,SAME,.EXIT,INSPTR)
+15 QUIT
POLMEM(POLHPTR,POLMCNT,POLMEMBS) ;EP - DISPLAY POLICY MEMBERS
+1 NEW POLMEM,CNT,RECNO,POLMEM,POL0,POL11,RELATION,FROM,THRU
+2 KILL POLMEMBS
+3 IF '$GET(POLHPTR)
WRITE !,"THERE ARE NO POLICY MEMBERS FOR THIS ELIGIBLITY RECORD!"
QUIT
+4 SET POLMEM=""
+5 FOR CNT=1:1
SET POLMEM=$ORDER(^AUPNPRVT("C",POLHPTR,POLMEM))
IF 'POLMEM
QUIT
Begin DoDot:1
+6 SET RECNO=0
+7 FOR
SET RECNO=$ORDER(^AUPNPRVT("C",POLHPTR,POLMEM,RECNO))
IF 'RECNO
QUIT
Begin DoDot:2
+8 SET POL0=$GET(^AUPNPRVT(POLMEM,0))
+9 SET POL11=$GET(^AUPNPRVT(POLMEM,11,RECNO,0))
+10 ;AG*7.1*2 IM21986
+11 IF POL11=""
KILL ^AUPNPRVT("C",POLHPTR,POLMEM,RECNO)
QUIT
+12 SET PTPTR=$PIECE(POL0,U)
+13 SET RELATION=$PIECE(POL11,U,5)
+14 SET FROM=$PIECE(POL11,U,6)
+15 SET THRU=$PIECE(POL11,U,7)
+16 IF RELATION'=""
SET RELATION=$PIECE($GET(^AUTTRLSH(RELATION,0)),U)
IF RELATION="SELF"
SET POLMEMBS("SELF")=POLMEM
+17 WRITE !,CNT+13,")"
+18 SET POLMEMBS(CNT+13,POLMEM,RECNO)=""
+19 IF PTPTR'=""
WRITE " "_$EXTRACT($PIECE($GET(^DPT(PTPTR,0)),U),1,17)
+20 WRITE ?22,$PIECE(POL11,U,12)
+21 ;AG*7.1*8
NEW AGPH
+22 SET AGPH=$PIECE($GET(^AUPNPRVT(POLMEM,11,RECNO,2)),U)
+23 IF AGPH]""
WRITE ?26,$EXTRACT(AGPH,1,16)
+24 IF AGPH=""
Begin DoDot:3
+25 SET AGPH=$PIECE($GET(^AUPNPRVT(POLMEM,11,RECNO,0)),U,8)
+26 WRITE ?26,$EXTRACT($PIECE($GET(^AUPN3PPH(AGPH,0)),U,4),1,16)
End DoDot:3
+27 WRITE ?42,$PIECE($GET(^AUPNPAT(POLMEM,41,DUZ(2),0)),U,2)
+28 WRITE ?50,$EXTRACT(RELATION,1,9)
+29 IF FROM'=""
SET FROM=$$FMTE^XLFDT(FROM,5)
+30 ;W ?60,FROM
+31 ;AG*7.1*2
WRITE ?59,FROM
+32 IF THRU'=""
SET THRU=$$FMTE^XLFDT(THRU,5)
WRITE "-",THRU
End DoDot:2
End DoDot:1
+33 SET POLMCNT=CNT-1
+34 QUIT
1 ;
+1 ;;Policy Holder.^?3^9000003.1^.01^!^1^EDITEM1~AGEDPRVP(ID0,POLHPTR)||||
+2 ;;^?3^9000003.1^.02^?0^^||||D NOTREG^AGEDPRV1(POLHPTR) W ?50,$C(124)
+3 ;;Gender^?3^9000003.1^.08^?50^5^EDITGEN~AGEDPRVP(POLHPTR,CALLER)
+4 ;;Policy or SSN.^?3^9000003.1^.04^!^2^EDITPOLN~AGEDPRVP(POLHPTR)||||W ?50,$C(124)
+5 ;;Date of Birth^?3^9000003.1^.19^?50^6^EDITDOB~AGEDPRVP(POLHPTR,CALLER)^
+6 ;;Effective Date^?3^9000003.1^.17^!^3^EFFDT~AGEDPRVP(POLHPTR)||||W ?40,$C(124)
+7 ;;PCP^?3^9000006.11^.14^?40^7^EDITPCP~AGEDPRVI(ID0,ID1,CALLER)|
+8 ;;Expire Date...^?3^9000003.1^.18^!^4^EDITEXP~AGEDPRVP(POLHPTR)||||W ?40,$C(124)
+9 ;;CD Name.....^?3^9000003.1^2^?40^8^EDCARDNM~AGEDPRVP(POLHPTR)
+10 ;;-HOLDER'S EMPLOYER INFO---------------------------------------------------------
+11 ;;Status........^?3^9000003.1^.15^!^9^EDITEMPL~AGEDPRVP(POLHPTR,"","",CALLER)||||W ?40,$C(124)
+12 ;;Employer^?3^9000003.1^.16^?41^10^EDITEMP~AGEDPRVP(POLHPTR,CALLER)^||
+13 ;;-INSURER INFORMATION------------------------------------------------------------
+14 ;;^?0^9000006.11^.01^!^^||||W ?40,$C(124)
+15 ;;Grp Name^?3^9000003.1^.06^?41^11^EDITGRP~AGEDPRVP(POLHPTR,CALLER)^||||
+16 ;;^?3^9999999.18^.02^!^^^||||W ?40,$C(124)
+17 ;;Grp Number^?3^9999999.77^.02^?45^^^|||
+18 ;;^?3^9999999.18^.03;.04;.05;^!^^^||||W ", ";W " ";W ?40,$C(124)
+19 ;;Coverage^?3^9999999.65^.01^?41^12^EDITCOV~AGEDPRVP(POLHPTR,CALLER)^||||W !|
+20 ;;^?3^9999999.18^.06^?0^^^||||
+21 ;;Ins. Type^?3^9999999.18^.211^?23^^^||||W ?40,$C(124)
+22 ;;CCopy^?3^9000006.11^.15^?41^13^EDITCC~AGEDPRVI(ID0,ID1,CALLER)^|||
+23 ;;----Policy Members----PC-----Member #------HRN-----Rel----------From/Thru-------
+24 ;;Policy Member^?3^9000006.11^.^?0^^^|||I CAPTION'[("Policy Member")|
+25 ;;*END*
