AGEDGUAR.m

AGEDGUAR ; IHS/ASDS/TPF - EDIT/DISP GUARANTOR SCREEN ;    

 ;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007

 ;

EN(GD0,GD1,GD2,NEWENTRY,AGSELECT,ALLFLDRQ) ;EP -

 ;ALLFLDRQ = TRUE IF THE PAT IS NON-INDIAN

 I $G(ALLFLDRQ)="" S ALLFLDRQ=$$ISNONIND^AGUTILS(DFN)

 I $G(AGSELECT)'="" S NONPER=$P(AGSELECT,U,14)'[("AUPNPAT")

 K GUARDEL

 S EXIT=0

 I NEWENTRY D  I EXIT W !,"Entry not made." H 2 D CLEANZER(GD0),END Q

 .S SAME=0

 .D DRAW,WMSG

 .D NEWENTRY Q:EXIT

 .D NEWGUAR Q:EXIT

 .D:'SAME EDITDOB

 .D EDITPO

 .D:'SAME EDITSEX

 .D NEWEFFDT Q:EXIT

 .D:'SAME EDITDEP

 .S COMPIEN=GD0_","_GD1_","_GD2

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

 .S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,GD0_",0)")  ;AG*7.1*1 IM18549

 .S NEWENTRY=0

 S COMPIEN=GD0_","_GD1_","_GD2

VAR D DRAW

 I $D(AGSEENLY) K DIR S DIR("A")="Press Return...",DIR(0)="FO" D ^DIR Q

 W !,AGLINE("EQ")

 K DIR

 S DIR("A")="ENTER ACTION (<E>dit"_$S($D(^XUSEC("AGZMGR",DUZ)):", <A>dd to the insurer file):",1:")")

 S DIR(0)="SAO^"_$S($D(^XUSEC("AGZMGR",DUZ)):"A:ADD;",1:"")_"E:EDIT"

 D ^DIR

 I Y="",('$O(^AUPNGUAR(GD0,1,GD1,11,0))!(GD2="")) D CLEAN(GD0) D END Q

 I $D(MYERRS("C","E")),(Y'?1N.N),(Y'="E"),('ALLFLDRQ) W !,"ERRORS ON THIS PAGE. PLEASE EDIT BEFORE EXITING!!" H 3 G VAR

 Q:Y=$G(AGOPT("ESCAPE"))

 I ALLFLDRQ,(Y'?1N.N),(Y'="E") I $$ALLFLDRQ(.ENTRYARY) W !,"PATIENT IS NON-INDIAN AND MUST HAVE ALL GUARANTOR DATA ENTERED!!" H 3 G VAR

 Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)

 I Y="A" D ADDINS G VAR

 K DIR

 S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "

 D READ^AGED1

 I ($D(MYERRS("C","E"))&(Y'?1N.N)),(Y'["V"),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR

 Q:Y=$G(AGOPT("ESCAPE"))

 I (ALLFLDRQ&(Y'?1N.N)),(Y'=AGOPT("ESCAPE")) I $$ALLFLDRQ(.ENTRYARY) W !,"PATIENT IS NON-INDIAN AND MUST HAVE ALL GUARANTOR DATA ENTERED!!" H 3 G VAR

 G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))

 Q:$D(DFOUT)!$D(DTOUT)

 I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR

 S AGY=Y

 F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N"))  D @($P(AG("C"),",",AG("SEL")))

 I $G(GUARDEL) Q  ;NO GUAR, RET TO SUMM PG

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

 ;S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2))  ;AG*7.1*1 IM18549

 S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,GD0_",0)")  ;AG*7.1*2 ERROR FOUND IN PATCH 2 TESTING

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

 K AGI,AGY

 G VAR

ADDINS ;EP - ADD INSURER TO AUTNINS

 D ^AGBAN,^AGTMINS

 Q

CLEAN(GD0) ;EP - DEL EMPTY REC

 I '$O(^AUPNGUAR(GD0,1,GD1,11,0)) D

 .D CLEANZER(GD0)

 Q

CLEANZER(GD0) ;EP

 K DIK,DA

 S DIK="^AUPNGUAR(",DA=GD0 D ^DIK

 Q

END K DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN

 K WDFN,REC,NEWENTRY,ROUTID,DEFEDDT,ENTRYARY,DEFEFFDT,GUARDEL,COMPIEN

 Q

DRAW ;EP

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

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

 D ^AGED

 D GETAW

 Q

GETAW ;

 K DEFEFFDT,DEFDEPEN

 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=$P($P(AGSCRN,U,7),"|",1)

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

 .. S D0=GD0

 .. I DIC'["." S D0=D0_","

 .. E  S D0=GD1_","_D0_","

 .. I DIC[("V") D

 ... S DIC=$$GETVDIC($P($P($G(^AUPNGUAR(GD0,1,GD1,0)),U),";",2))

 ... S D0=$P($P($G(^AUPNGUAR(GD0,1,GD1,0)),U),";")

 ... I DIC=9000001,(DR=.02) S DIC=2,DR=".111"

 ... I DIC=9000001,(DR=".03;.04;.05") S DIC=2,DR=".114;.115;.116"

 ... I DIC=9000001,(DR=.06) S DIC=2,DR=.131

 ..;I DIC=9000043.0111 S ITEMNUM=5 S WD0=","_GD1_","_GD0_"," D GETDATES(WD0) Q

 ..I DIC=9000043.0111 S ITEMNUM=5 S WD0=","_GD1_","_GD0_"," D GETDATES^AGEDGUA1(WD0) Q  ;AG*7.1*1 SAC REQUIREMENT ROUTINE TOO LARGE MOVED SUBRTN

 .. N PIECE

 .. S VDR=DR

 .. F PIECE=1:1 S DR=$P(VDR,";",PIECE) Q:DR=""  D

 ... I CAPTION="STREET" S ITEMNUM=AG("N") S ITEMNUM=ITEMNUM+1 W ?0,ITEMNUM_". STREET: " S AG("N")=ITEMNUM,$P(AG("C"),",",ITEMNUM)=TAGCALL

 ... I DIC=2,(DR=.115) S DR="STATE:ABBREVIATION"

 ... I DIC'=9000043.0101,(DR=.04) S DR="STATE:ABBREVIATION"

 ... I $P(PREEXEC,";",PIECE)'="" X $P(PREEXEC,";",PIECE)

 ... I $P(EXECUTE,";",PIECE)="" S ENTRY=$$GET1^DIQ(DIC,D0,DR,FLAG) W ENTRY S:ITEMNUM'="" ENTRYARY(ITEMNUM)=ENTRY

 ... I $P(EXECUTE,";",PIECE)'="" S D0=$TR(D0,",") X $P(EXECUTE,";",PIECE)

 ... I $P(POSTEXEC,";",PIECE)'="" X $P(POSTEXEC,";",PIECE)

 ..K PIECE,VDR

 ..I DIC="XXXXXXXXX" D

 ...S ITEMNUM=AG("N")

 ...S AG("FLDCNT")=ITEMNUM

 ...I $D(AG("TMPDEP")) K AG("TMPDEP")

 ...D FINDDEP

 K MYERRS,MYVARS

 D FETCHERR^AGEDERR(AG("PG"),.MYERRS)

 S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="FINDGUAR",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)

 I '$G(NEWENTRY) D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)

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

 D VERIF^AGUTILS

 Q

GETVDIC(VROOT) ;EP - PROCESS VAR PTR FLD

 Q:VROOT="" ""

 S VROOT=U_VROOT_"0)"

 Q +$P($G(@VROOT),U,2)

WMSG ;EP - MSG TO DISP IF NO ENTRY IN FILE

 W !,"You must first enter a GUARANTOR"

 Q

NEWENTRY ;EP - CREATE TOP LEVEL

 W !!

 K DIC,DIE,DR,DA

 S DIC="^AUPNGUAR("

 S DIC(0)="L"

 S X="`"_DFN

 K DD,DO

 D ^DIC

 I +Y<0 S EXIT=1

 S GD0=+Y

 ;S NEWENTRY=0

 Q

NEWGUAR ;

 K DIR

 S DIR("B")="SAME"

 S DIR("A")="Select GUARANTOR"

 S DIR(0)="FO^1:30"

 D ^DIR

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S EXIT=1 Q

 S X=Y

 S SAME=X="SAME"

 I X="SAME" D SAME(DFN) Q

 K DIC,DIE,DR,DA,DIR

 S TEMPDFN=DFN

 S DA(1)=GD0

 S DIC("S")="I $G(Y)'=TEMPDFN"

 S DIC="^AUPNGUAR("_DA(1)_",1,"

 S DIC(0)="MEQL"

 K DD,DO

 D ^DIC

 S DFN=TEMPDFN

 ;I +Y<0,(X="SAME") D SAME Q

 I +Y<0 S EXIT=1 Q

 S GD1=+Y

 I ALLFLDRQ,(+Y<0) W !,"PATIENT IS NON-INDIAN AND MUST HAVE ALL GUARANTOR DATA ENTERED!!" H 3 G NEWGUAR

 S NONPER=$P(Y,U,2)'[("AUPNPAT")  ;NOT IN AUPNPAT SO THIS IS NOT A PERSON

 ;THIS DEPENDS ON WHAT THEY DECIDE TO DO ABOUT ENTERING GURANTORS WHICH ARE NOT

 ;PATS AND ARE NOT EMPLOYERS OR INSURERS

 I ALLFLDRQ,+Y S ENTRYARY(1)=+Y

 Q

 ;IF SAME ENTERED THEN THE GUARANTOR IS THE PATIENT

SAME(X) ;EP

 ;IF THE USER ENTERS SAME THEN IT IS ASSUMED THE GUARANTOR IS THE SAME AS

 ;THE PATIENT SO THE LOOKUP WILL ONLY BE ON THE PATIENT FILE

 N SAMESEX

 S DIC("V")="I +Y(0)=9000001"

 S DA(1)=GD0

 S DIC="^AUPNGUAR("_DA(1)_",1,"

 S DIC(0)="LMEQ"

 K DD,DO

 S TEMPDFN=X

 S X=$P($G(^DPT(X,0)),U)

 D ^DIC

 I +Y<0 S EXIT=1 Q

 S DFN=TEMPDFN

 S GD1=+Y

 S SAMESEX=$P($G(^DPT(DFN,0)),U,2)

 S SAMEDOB=$P($G(^DPT(DFN,0)),U,3)

 K DIC,DR,DIE,DA,DD,DO

 S DA(1)=GD0

 S DA=GD1

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 S DR=".04///^S X=SAMEDOB;.05///^S X=SAMESEX;.06///^S X=""SELF"""

 D ^DIE

 Q

NEWEFFDT ;

 K DIC,DIE,DR,DA,X

 S DA(2)=GD0

 S DA(1)=GD1

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

 S DIC(0)="ALMEQ"

 I $G(AGY)'="" I $D(DEFEFFDT(AGY)) S DIC("B")=$G(DEFEFFDT(AGY))

 K DD,DO

 D ^DIC

 I +Y<0 S EXIT=1 Q

 S GD2=+Y

 I ALLFLDRQ,(+Y<0) W !,"PATIENT IS NON-INDIAN AND MUST HAVE ALL GUARANTOR DATA ENTERED!!" H 3 G NEWEFFDT

 I $P(Y,U,3) D EDITEXP Q

 D EDITEFF

 Q

EDITGUAR ;GUAR NAME

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

 S GUARDEL=0

 S DA(1)=GD0

 S DA=GD1

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 S DR=.01

 I ALLFLDRQ S DR=".01R",DIE("NO^")=""

 I DR'[("R") I $$ISREQ^AGFLDREQ(9000043,.01) S DIE("NO^")="",DR=".01R"

 D ^DIE

 I ALLFLDRQ S ENTRYARY(1)=$G(X)

 I '$D(DA) S GUARDEL=1

 K DIC,DR,DIE,DA

 Q

EDITREF ;REF #

 K DIC,DR,DIE,DA,DD,DO

 S DA(1)=GD0

 S DA=GD1

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 S DR=.02

 I ALLFLDRQ S DR=".02R",DIE("NO^")=""

 I DR'[("R") I $$ISREQ^AGFLDREQ(9000043,.02) S DIE("NO^")="",DR=".02R"

 D ^DIE

 I ALLFLDRQ S ENTRYARY(2)=$G(X)

 K DIC,DR,DIE,DA

 Q

EDITPO ;PO #

 K DIC,DR,DIE,DA,DD,DO

 S DA(1)=GD0

 S DA=GD1

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 I ALLFLDRQ S DR=".03R",DIE("NO^")=""

 E  S DR=.03

 D ^DIE

 I ALLFLDRQ S ENTRYARY(3)=$G(X)

 K DIC,DR,DIE,DA

 Q

EDITDOB ;DOB

 K DIC,DR,DIE,DA,DD,DO

 S DA(1)=GD0

 S DA=GD1

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 S DR=.04

 I ALLFLDRQ,('$G(NONPER)) S DR=".04R",DIE("NO^")=""

 I DR'[("R") I $$ISREQ^AGFLDREQ(9000043,.04) S DIE("NO^")="",DR=".04R"

 D ^DIE

 I ALLFLDRQ S ENTRYARY(4)=$G(X)

 K DIC,DR,DIE,DA

 Q

EDITSEX ;GENDER

 K DIC,DR,DIE,DA,DD,DO

 S DA(1)=GD0

 S DA=GD1

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 S DR=.05

 I ALLFLDRQ,('$G(NONPER)) S DR=".05R",DIE("NO^")=""

 I DR'[("R") I $$ISREQ^AGFLDREQ(9000043,.05) S DIE("NO^")="",DR=".05R"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDITEFF ;EFF DT

 K DIC,DR,DIE,DA,DD,DO

 S DA=GD2

 S DA(1)=GD1

 S DA(2)=GD0

 S DIE="^AUPNGUAR("_DA(2)_",1,"_DA(1)_",11,"

 I ALLFLDRQ S DR(3,9000043.0111)=".01R",DIE("NO^")=""

 E  S DR(3,9000043.0111)=".01"

 S DR=".01"

 D ^DIE

 Q:'$D(DA)

 K DIC,DR,DIE,DA

 D EDITEXP

 Q

EDITEXP ;EXP DT

 K DIC,DR,DIE,DA,DD,DO

 S DA=GD2

 S DA(1)=GD1

 S DA(2)=GD0

 S DIE="^AUPNGUAR("_DA(2)_",1,"_DA(1)_",11,"

 S DR=".02"

 I ALLFLDRQ S DR(3,9000043.0111)=".02R",DIE("NO^")=""

 E  S DR(3,9000043.0111)=".02"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

 ;EDIT ADDRESS OF GUARANTOR

EDITADD ;EP

 K DIC,DR,DIE,DA,DD,DO

 ;IF ALL ADDRESS FIELD ARE MISSING

 S ALLOW=$$GUARADD^AGEDERR2($G(AGSELECT))

 I 'ALLOW W !,"ADDRESS MUST BE EDITED IN TABLE MAINTENANCE!!" H 2 Q

 ;WHAT FILE ARE WE LOOKING AT?

 S DIE=$P(^AUPNGUAR(GD0,1,GD1,0),U)

 S DA=$P(DIE,";")

 S DIE=U_$P(DIE,";",2)

 S:DIE[("AUPNPAT") DIE="^DPT("

 I DIE[("DPT") S DR=".111;.114;.115;.116;.131"

 E  S DR=".02;.03;.04;.05;.06"

 D ^DIE

 Q

ALLFLDRQ(ARRAY) ;EP - ARE ALL FLDS ENTERED

 N MISSING

 S MISSING=0

 S ITEM="" F  S ITEM=$O(ARRAY(ITEM)) Q:ITEM=""  D

 .I $G(NONPER),(ITEM=4!(ITEM=5)) S ARRAY(ITEM)="NA"

 .I $G(ARRAY(ITEM))="" S MISSING=1

 Q MISSING

FINDDEP ;EP - FIND DEPS

 S AG("DEP")=0

 S AG("GUAR")=$P($G(^AUPNGUAR(GD0,1,GD1,0)),U)

 F  S AG("DEP")=$O(^AUPNGUAR("C",AG("GUAR"),AG("DEP"))) Q:'AG("DEP")  D

 . S AG("PREC")=0

 . F  S AG("PREC")=$O(^AUPNGUAR("C",AG("GUAR"),AG("DEP"),AG("PREC"))) Q:'AG("PREC")  D

 .. S AG("FLDCNT")=AG("FLDCNT")+1,AG("TMPDEP",AG("FLDCNT"))=AG("DEP")_U_AG("PREC")

 .. S DEFDEPEN(AG("FLDCNT"))=AG("DEP")_","_AG("PREC")

 .. S $P(AG("C"),",",AG("FLDCNT"))="EDITDEP"

 .. W !,AG("FLDCNT"),". ",?4,$P($G(^DPT(AG("DEP"),0)),U)

 .. W ?30,$P($G(^AUPNPAT(AG("DEP"),41,DUZ(2),0)),U,2)

 .. I $P($G(^AUPNGUAR(AG("DEP"),1,GD1,0)),U,6)'="" D

 ... W ?47,$P($G(^AUTTRLSH($P($G(^AUPNGUAR(AG("DEP"),1,GD1,0)),U,6),0)),U)

 .. W ?67,$$AGE^AUPNPAT(AG("DEP"))

 K AG("DEP"),AG("PREC"),AG("GUAR")

 I $D(AG("TMPDEP")) S AG("N")=AG("FLDCNT")

 Q

EDITDEP ;EP - EDIT RELATIONSHIP FLD OF DEP

 K DIC,DR,DIE,DA,DD,DO

 S DA(1)=GD0

 S DA=GD1

 I $G(AGY)'="",$D(DEFDEPEN(AGY)) S DA=$P($G(DEFDEPEN(AGY)),",",2),DA(1)=$P($G(DEFDEPEN(AGY)),",")

 S DIE="^AUPNGUAR("_DA(1)_",1,"

 S DR=".06"

 I ALLFLDRQ,('$G(NONPER)) S DR=".06R",DIE("NO^")=""

 I DR'[("R") I $$ISREQ^AGFLDREQ(9000043,.06) S DIE("NO^")="",DR=".06R"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

 ;

 ; 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 LABEL IF POPULATED

 ; 2      CAPDENT    POS ON LINE TO DISP CAP 

 ; 3      DIC        FILE OR SUBFILE #

 ; 4      DR         FLD # - THESE CAN BE SEPARATED BY ";" THIS ALLOWS

 ;                   MULT 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 EDIT

 ; BAR "|" DELIMITED

 ; PIECE  VAR        DESC

 ; -----  --------   -----------

 ; 2      EXECUTE    EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO.

 ;                   EXECUTED AFT FLD PRINT. IF MULT FLDS ARE PRINTED

 ;                   THEN MULT EXECUTE CODES CAN BE SEPARATED BY ";".

 ; 3      PREEXEC    EXECUTE CODE TO DO BEF FLD PRINTS. USE TO SCREEN OUT

 ;                   PRINTING A FLD VALUE. FOR MULT 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 MULT SEPARATE BY ";"

 ;

 ;AG*7.1*2 CHANGED  ;;MOTHER'S NAME^?3^2^.2402^?45^^^|||W $C(124)

 ;           TO MOTHER'S MAIDEN NAME

1 ;

 ;;GUARANTOR NAME^?3^9000043.0101^.01^!^1^EDITGUAR

 ;;REFERENCE #^?0^9000043.0101^.02^!!^2^EDITREF

 ;;PO NUMBER^?3^9000043.0101^.03^?37^3^EDITPO

 ;;DATE OF BIRTH^?3^9000043.0101^.04^!^4^EDITDOB^

 ;;GENDER^?3^9000043.0101^.05^!^5^EDITSEX

 ;;-Effective Date--------------------------Expiration Date------------------------

 ;;^?0^9000043.0111^.01^!?0^^NEWEFFDT

 ;;-GUARANTOR ADDRESS--------------------------------------------------------------

 ;;STREET^?3^9000043.0101V^.02^!^^EDITADD|||I 0

 ;;MOTHER'S MAIDEN NAME^?3^2^.2403^?40^^^|||W $C(124)

 ;;CITY,STATE,ZIP^?3^9000043.0101V^.03;.04;.05^!^^|;;|||W ", ";W " ";|

 ;;FATHER'S NAME^?3^2^.2401^?40^^^|||W $C(124)

 ;;PHONE^?3^9000043.0101V^.06^!^^^

 ;;-DEPENDENTS-------------------HRN--------------REL----------------AGE-----------

 ;;^?0^XXXXXXXXX^.06^?0^^^

 ;;*END*

AGEDGUAR  ; IHS/ASDS/TPF - EDIT/DISP GUARANTOR SCREEN ;    

 +1       ;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007

 +2       ;

EN(GD0,GD1,GD2,NEWENTRY,AGSELECT,ALLFLDRQ) ;EP -

 +1       ;ALLFLDRQ = TRUE IF THE PAT IS NON-INDIAN

 +2        IF $GET(ALLFLDRQ)=""

               SET ALLFLDRQ=$$ISNONIND^AGUTILS(DFN)

 +3        IF $GET(AGSELECT)'=""

               SET NONPER=$PIECE(AGSELECT,U,14)'[("AUPNPAT")

 +4        KILL GUARDEL

 +5        SET EXIT=0

 +6        IF NEWENTRY

               Begin DoDot:1

 +7                SET SAME=0

 +8                DO DRAW

                   DO WMSG

 +9                DO NEWENTRY

                   IF EXIT

                       QUIT 

 +10               DO NEWGUAR

                   IF EXIT

                       QUIT 

 +11               IF 'SAME

                       DO EDITDOB

 +12               DO EDITPO

 +13               IF 'SAME

                       DO EDITSEX

 +14               DO NEWEFFDT

                   IF EXIT

                       QUIT 

 +15               IF 'SAME

                       DO EDITDEP

 +16               SET COMPIEN=GD0_","_GD1_","_GD2

 +17      ;S AGSELECT=$$UPDTSEL^AGUTILS("FINDGUAR",.AGINS,COMPIEN)

 +18      ;AG*7.1*1 IM18549

                   SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,GD0_",0)")

 +19               SET NEWENTRY=0

               End DoDot:1

               IF EXIT

                   WRITE !,"Entry not made."

                   HANG 2

                   DO CLEANZER(GD0)

                   DO END

                   QUIT 

 +20       SET COMPIEN=GD0_","_GD1_","_GD2

VAR        DO DRAW

 +1        IF $DATA(AGSEENLY)

               KILL DIR

               SET DIR("A")="Press Return..."

               SET DIR(0)="FO"

               DO ^DIR

               QUIT 

 +2        WRITE !,AGLINE("EQ")

 +3        KILL DIR

 +4        SET DIR("A")="ENTER ACTION (<E>dit"_$SELECT($DATA(^XUSEC("AGZMGR",DUZ)):", <A>dd to the insurer file):",1:")")

 +5        SET DIR(0)="SAO^"_$SELECT($DATA(^XUSEC("AGZMGR",DUZ)):"A:ADD;",1:"")_"E:EDIT"

 +6        DO ^DIR

 +7        IF Y=""

               IF ('$ORDER(^AUPNGUAR(GD0,1,GD1,11,0))!(GD2=""))

                   DO CLEAN(GD0)

                   DO END

                   QUIT 

 +8        IF $DATA(MYERRS("C","E"))

               IF (Y'?1N.N)

                   IF (Y'="E")

                       IF ('ALLFLDRQ)

                           WRITE !,"ERRORS ON THIS PAGE. PLEASE EDIT BEFORE EXITING!!"

                           HANG 3

                           GOTO VAR

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

               QUIT 

 +10       IF ALLFLDRQ

               IF (Y'?1N.N)

                   IF (Y'="E")

                       IF $$ALLFLDRQ(.ENTRYARY)

                           WRITE !,"PATIENT IS NON-INDIAN AND MUST HAVE ALL GUARANTOR DATA ENTERED!!"

                           HANG 3

                           GOTO VAR

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

               QUIT 

 +12       IF Y="A"

               DO ADDINS

               GOTO VAR

 +13       KILL DIR

 +14       SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "

 +15       DO READ^AGED1

 +16       IF ($DATA(MYERRS("C","E"))&(Y'?1N.N))

               IF (Y'["V")

                   IF (Y'=AGOPT("ESCAPE"))

                       WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"

                       HANG 3

                       GOTO VAR

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

               QUIT 

 +18       IF (ALLFLDRQ&(Y'?1N.N))

               IF (Y'=AGOPT("ESCAPE"))

                   IF $$ALLFLDRQ(.ENTRYARY)

                       WRITE !,"PATIENT IS NON-INDIAN AND MUST HAVE ALL GUARANTOR DATA ENTERED!!"

                       HANG 3

                       GOTO VAR

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

               GOTO END

           IF $DATA(AG("ERR"))

               GOTO VAR

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

               QUIT 

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

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

               HANG 2

               GOTO VAR

 +22       SET AGY=Y

 +23       FOR AGI=1:1

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

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

                   QUIT 

               DO @($PIECE(AG("C"),",",AG("SEL")))

 +24      ;NO GUAR, RET TO SUMM PG

           IF $GET(GUARDEL)

               QUIT 

 +25      ;S AGSELECT=$$UPDTSEL^AGUTILS("FINDGUAR",.AGINS,COMPIEN)

 +26      ;S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2))  ;AG*7.1*1 IM18549

 +27      ;AG*7.1*2 ERROR FOUND IN PATCH 2 TESTING

           SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,GD0_",0)")

 +28       DO UPDATE1^AGED(DUZ(2),DFN,3,"")

 +29       KILL AGI,AGY

 +30       GOTO VAR

ADDINS    ;EP - ADD INSURER TO AUTNINS

 +1        DO ^AGBAN

           DO ^AGTMINS

 +2        QUIT 

CLEAN(GD0) ;EP - DEL EMPTY REC

 +1        IF '$ORDER(^AUPNGUAR(GD0,1,GD1,11,0))

               Begin DoDot:1

 +2                DO CLEANZER(GD0)

               End DoDot:1

 +3        QUIT 

CLEANZER(GD0) ;EP

 +1        KILL DIK,DA

 +2        SET DIK="^AUPNGUAR("

           SET DA=GD0

           DO ^DIK

 +3        QUIT 

END        KILL DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN

 +1        KILL WDFN,REC,NEWENTRY,ROUTID,DEFEDDT,ENTRYARY,DEFEFFDT,GUARDEL,COMPIEN

 +2        QUIT 

DRAW      ;EP

 +1        SET AG("PG")="4GUARA"

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

 +3        DO ^AGED

 +4        DO GETAW

 +5        QUIT 

GETAW     ;

 +1        KILL DEFEFFDT,DEFDEPEN

 +2        KILL AG("C")

 +3        FOR AG=1:1

               Begin DoDot:1

 +4                SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,15)

 +5                IF AGSCRN[("*END*")

                       QUIT 

 +6                SET CAPTION=$PIECE(AGSCRN,U)

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

                       WRITE !,CAPTION

                       QUIT 

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

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

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

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

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

 +13               SET TAGCALL=$PIECE($PIECE(AGSCRN,U,7),"|",1)

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

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

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

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

 +18               IF TAGCALL'=""

                       SET $PIECE(AG("C"),",",ITEMNUM)=TAGCALL

 +19               WRITE @NEWLINE

 +20               WRITE ITEMNUM

 +21               WRITE $SELECT(ITEMNUM'="":". ",1:"")

 +22               IF PRECAPEX=""

                       WRITE @CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION_": ",$GET(CAPTION)="":"",1:$PIECE($GET(^DD(DIC,DR,0)),U)_": ")

 +23               IF PRECAPEX'=""

                       XECUTE PRECAPEX

                       IF $TEST

                           WRITE @CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION_": ",$GET(CAPTION)="":"",1:$PIECE($GET(^DD(DIC,DR,0)),U)_": ")

 +24               IF 'NEWENTRY

                       Begin DoDot:2

 +25                       SET FLAG=""

 +26                       SET D0=GD0

 +27                       IF DIC'["."

                               SET D0=D0_","

 +28                      IF '$TEST

                               SET D0=GD1_","_D0_","

 +29                       IF DIC[("V")

                               Begin DoDot:3

 +30                               SET DIC=$$GETVDIC($PIECE($PIECE($GET(^AUPNGUAR(GD0,1,GD1,0)),U),";",2))

 +31                               SET D0=$PIECE($PIECE($GET(^AUPNGUAR(GD0,1,GD1,0)),U),";")

 +32                               IF DIC=9000001

                                       IF (DR=.02)

                                           SET DIC=2

                                           SET DR=".111"

 +33                               IF DIC=9000001

                                       IF (DR=".03;.04;.05")

                                           SET DIC=2

                                           SET DR=".114;.115;.116"

 +34                               IF DIC=9000001

                                       IF (DR=.06)

                                           SET DIC=2

                                           SET DR=.131

                               End DoDot:3

 +35      ;I DIC=9000043.0111 S ITEMNUM=5 S WD0=","_GD1_","_GD0_"," D GETDATES(WD0) Q

 +36      ;AG*7.1*1 SAC REQUIREMENT ROUTINE TOO LARGE MOVED SUBRTN

                           IF DIC=9000043.0111

                               SET ITEMNUM=5

                               SET WD0=","_GD1_","_GD0_","

                               DO GETDATES^AGEDGUA1(WD0)

                               QUIT 

 +37                       NEW PIECE

 +38                       SET VDR=DR

 +39                       FOR PIECE=1:1

                               SET DR=$PIECE(VDR,";",PIECE)

                               IF DR=""

                                   QUIT 

                               Begin DoDot:3

 +40                               IF CAPTION="STREET"

                                       SET ITEMNUM=AG("N")

                                       SET ITEMNUM=ITEMNUM+1

                                       WRITE ?0,ITEMNUM_". STREET: "

                                       SET AG("N")=ITEMNUM

                                       SET $PIECE(AG("C"),",",ITEMNUM)=TAGCALL