AGEDBEB.m

AGEDBEB ; IHS/ASDS/TPF - EDIT/DISP BENEFITS COORDINATOR - CASE SCREEN ;    

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

EN(RD0,RD1,NEWENTRY) ;

 S EXIT=0

 ;I NEWENTRY D  Q:EXIT  S NEWENTRY=0

 I NEWENTRY D  Q:EXIT  D UPDATE1^AGED(DUZ(2),DFN,3,"") S NEWENTRY=0 ;AG*7.1*2 IM22092

 .D DRAW,WMSG,NEWENTRY I $G(Y)<0 W !,"No entry made" H 2 S EXIT=1 Q

 .D EDREAS I $G(X)="" D CLEAN(RD0) S EXIT=1 Q

 .D EDCASNUM

 .D EDCASTO

VAR D DRAW

 W !,AGLINE("EQ")

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

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

 K DIR

 I '$D(AGSENNLY) D

 .S DIR("A")="Change which item (1-"_AG("N")_") OR Add <A>pplication OR Add <S>penddown information"

 I $D(AGSEENLY) D

 .S:AG("N")>7 DIR("A")="Enter item number to view"

 .S:AG("N")<8 DIR("A")="Press return to continue"

 .S DIR(0)="LO^9:"_AG("N")

 D READ^AGED1

 I $D(AGSEENLY),(+Y'>0) Q

 ;I $D(AGSEENLY),((Y<9)!(Y>AG("N"))) W !,"Enter a number between 9 and "_AG("N") H 2 G VAR

 ;AG*7.1*2 IM20457;IM20809

 I $D(AGSEENLY),((Y<8)!(Y>AG("N"))) W !,"Enter a number between 8 and "_AG("N") H 2 G VAR

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

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

 I $G(Y)="A" D EN^AGEDBED("_AUPNPAT_","""",1,RD1) G VAR

 I $G(Y)="S" D EN^AGEDBEH("_AUPNPAT_","""",1,RD1) G VAR

 I $D(DQOUT)!(+Y<1)!(+Y>AG("N")),('$D(CHOICES(+Y))) W !!,"You must enter a number from 1 to ",AG("N"),!,"or 'A' to add application information.",!,"or 'S' to add SPEND DOWN information" H 3 G VAR

 I $D(CHOICES(+Y)) S DORTN=$S($P(CHOICES(+Y),U)[9000045:"EN^AGEDBED",1:"EN^AGEDBEH"),PARAM1=$P(CHOICES(+Y),U,2),PARAM2=$P(CHOICES(+Y),U,3) S DORTN=DORTN_"("_PARAM1_","_PARAM2_","_"0)" D @DORTN G VAR

 Q:'$D(Y)

 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 AGY=1,'$D(^AUPNBENR(RD0,11,RD1)) D CLEAN(RD0) Q

 D CLEAN(RD0) I '$D(^AUPNBENR(RD0)) Q

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

 I '$D(AGSEENLY) D UPDATE1^AGED(DUZ(2),DFN,3,"")  ;AG*7.1*2 REPORTED DURING TESTING

 K AGI,AGY

 G VAR

CLEAN(RD0) ;EP -

 I $O(^AUPNBENR(RD0,11,0))="" D

 .D CLEANZER(RD0)

 .W !,"RECORD DELETED!" H 3

 Q

CLEANZER(RD0) ;EP

 K DIK,DA

 S DIK="^AUPNBENR(",DA=RD0 D ^DIK

 Q

END ;CLEAN UP VARS

 K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC,NEWENTRY,ROUTID

 Q

DRAW ;EP

 K CHOICES

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

 S AG("PG")="5BEB"

 D ^AGED

 D GETAW

 Q

GETAW ;DISP

 K AG("C")

 S VD0=RD0

 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 !,$E(CAPTION,2,199) Q

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

 . S VDR=$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 D0=RD0

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

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

 .. I DIC["9000044." D

 ... S D0=D0_","

 ... N PIECE

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

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

 .... I $P(EXECUTE,";",PIECE)="" W $$GET1^DIQ(DIC,D0,DR)

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

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

 ...K PIECE

 ..;LIST OPEN APPS

 .I DIC["9000045."  D

 .. Q:NEWENTRY

 .. S ITEM=8   ;PREV SECTION'S ITEMS END AT 8

 .. S VD0=$O(^AUPNAPPS("B",AUPNPAT,""))

 .. I VD0="" W !,"NO APPLICATIONS ASSOCIATED WITH THIS CASE",! Q

 .. S CASEPTR=RD1

 .. S VD0=$O(^AUPNAPPS("C",CASEPTR,""))

 .. I VD0="" W !,"NO APPLICATIONS ASSOCIATED WITH THIS CASE",! Q

 .. ;GET THE APPLICATIONS BELONGING TO THIS CASE

 .. S VD0=""

 .. F  S VD0=$O(^AUPNAPPS("C",CASEPTR,VD0)) Q:'VD0  D

 ... I $P($G(^AUPNAPPS(VD0,0)),U)'=$G(AUPNPAT) Q

 ... S BD1=0

 ... F  S BD1=$O(^AUPNAPPS("C",CASEPTR,VD0,BD1)) Q:'BD1  D

 ....S ITEM=ITEM+1

 .... S CHOICES(ITEM)=DIC_U_VD0_U_BD1

 .... S D0=BD1_","_VD0_","

 .... I ITEM=1 W ?0,ITEM_"."

 .... E  W !,ITEM_"."

 .... N PIECE

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

 ...... W $S(DR=.03:$E($$GET1^DIQ(DIC,D0,DR),1,20),1:$$GET1^DIQ(DIC,D0,DR))

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

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

 ....K PIECE

 .I DIC=9000044.1101 Q:NEWENTRY  D GETNOTES

 .I DIC="9000047.11"  D

 .. Q:NEWENTRY

 .. S VD0=$O(^AUPNCHS("B",AUPNPAT,""))

 .. I VD0="" W !,"NO SPEND DOWN INFORMATION ASSOCIATED WITH THIS CASE",! Q

 .. ;GET THE SPEND DOWN INFO BELONGING TO THIS CASE

 .. S CASEPTR=RD1

 .. S VD0=$O(^AUPNCHS("C",CASEPTR,""))

 .. I VD0="" W !,"NO SPEND DOWN INFORMATION ASSOCIATED WITH THIS CASE",! Q

 .. S VD0=""

 .. F  S VD0=$O(^AUPNCHS("C",CASEPTR,VD0)) Q:'VD0  D

 ... I $P($G(^AUPNCHS(VD0,0)),U)'=$G(AUPNPAT) Q

 ... S BD1=0

 ... F  S BD1=$O(^AUPNCHS("C",CASEPTR,VD0,BD1)) Q:'BD1  D

 ....S ITEM=ITEM+1

 .... S CHOICES(ITEM)=DIC_U_VD0_U_BD1

 .... S D0=BD1_","_VD0_","

 .... I ITEM=1 W ?0,ITEM_"."

 .... E  W !,ITEM_"."

 .... N PIECE

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

 ...... W $S(DR=.04:$J($$GET1^DIQ(DIC,D0,DR),6,2),(DR=.02!(DR=.03)):$E($$GET1^DIQ(DIC,D0,DR),1,15),1:$$GET1^DIQ(DIC,D0,DR))

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

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

 ....K PIECE

 ....D SPENDOWN

 S AG("N")=$G(ITEM)

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

 K MYERRS,MYVARS

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

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

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

 D VERIF^AGUTILS

 Q

SPENDOWN ;EP - GET SPEND DOWNS FOR THE DATE REFERRED

 S LSTONE=$O(^AUPNCHS(VD0,11,BD1,11,"B"),-1)

 S SPDDATA=$G(^AUPNCHS(VD0,11,BD1,11,LSTONE,0))

 S Y=$P(SPDDATA,U) X ^DD("DD") S SPDDATE=Y

 W ?39,$J($P(SPDDATA,U,3),8,2),?51,$P(SPDDATA,U,2),?67,SPDDATE

 Q

WMSG ;DISP MSG IF NO ENTRY IS FOUND IN ANY OF THE GUARAN

 ;FILES (EMPLOYER, PATIENT, INSURER)

 W !,"You must first enter a BENEFIT CASE DATE"

 Q

 ;;;;;;;;;;;;;;;;;;;;;;;

 ;EDIT BENEFIT CASE FLDS

 ;;;;;;;;;;;;;;;;;;;;;;;

 ;

NEWENTRY ;NEW ENTRY

 W !!

 K DIC,DIE,DR,DA

 S DIC="^AUPNBENR("

 S DIC(0)="L"

 S X="`"_DFN

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

 S TEMPDFN=DFN

 D ^DIC

 S DFN=TEMPDFN

 Q:+Y<0

 S RD0=+Y

 S NEWENTRY=0

NEWCASDT ;

 K DIC,DIE,DR,DA

 S DA(1)=RD0

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

 S DIC(0)="ALMEQ"

 S DIC("S")="I $P(^(0),U,7)'=""C"""

 K DD,DO

 D ^DIC

 I +Y>0 S RD1=+Y D STUFFBY Q

 Q

EDCOMBY ;EP - COMPLETED BY

 ;CHK TO SEE IF THERE ARE ANY MORE OPEN CASES AVAILABLE.

 ;IF NOT, DO NOT ALLOW CLOSING?

 ;REMOVE RESTRICTION ON CLOSING CASES IM20027,IM20008 AG*7.1*1

 ;I '$$ENUFOPEN(RD0) W !,"CANNOT DELETE THIS OPEN CASE - PATIENT HAS APPLICATIONS AND SPEND DOWN INFORMATION!" H 2 Q

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=.09

 D ^DIE

 I $G(X)'="",($G(X)'[U) D STUFSTAT,EDDTCOM

 K DIC,DR,DIE,DA

 Q

ENUFOPEN(RD0) ;EP - IF NO APPS OR SPEND DOWN INFO, OK TO DELETE

 I $$NOAPSCHS(DFN) Q 1

 N REC,OPEN

 S OPEN=0

 S REC=0

 F  S REC=$O(^AUPNBENR(RD0,11,REC)) Q:'REC  D

 .I $P(^AUPNBENR(RD0,11,REC,0),U,7)'="C" S OPEN=OPEN+1

 I '(OPEN>1) W !,"CANNOT DELETE THIS OPEN CASE - PATIENT HAS APPLICATIONS AND SPEND DOWN INFORMATION!"

 Q OPEN>1

EDDTCOM ;EP - DT COMPLETED

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=".11R"

 S DIE("NO^")=""

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDREAS ;CASE REASON

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=".12R"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDCASE ;CASE WORKER

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=.08

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDCASNUM ;CASE #

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=.05

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDTYPE ;CASE TYPE

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=.06

 D ^DIE

 K DIC,DR,DIE,DA

 Q

NODELALL(RD0) ;EP

 ;IF NO APPS OR SPEND DOWN INFO, IT'S OK TO DELETE

 I $$NOAPSCHS(DFN) Q 0

 ;MUST HAVE AT LEAST ONE "OPEN" CASE SO USER CAN ACCESS THE APPS

 ;AND SPEND DOWN INFO

 N NODELALL

 S NODELALL=0

 I $O(^AUPNBENR(RD0,11,0)) D   ;DO WE HAVE AT LEAST ONE ENTRY?

 .I $O(^AUPNBENR(RD0,11,0))=$O(^AUPNBENR(RD0,11,"B"),-1) D  ;IF TRUE, THERE'S ONE ENTRY LEFT AND WE CANNOT DELETE.

 ..S NODELALL=1

 ..W !,"CANNOT DELETE THIS DATE BECAUSE YOU HAVE APPLICATION AND SPEND DOWN INFORMATION CONNECTED TO IT!!" H 2

 Q NODELALL  ;MUST RETURN TRUE TO WORK WITH "DEL" NODE LOGIC IN ^DD

NOAPSCHS(DFN) ;EP

 ;ARE THERE APPS OR SPEND DOWN INFO FOR THIS PAT?

 Q '$D(^AUPNAPPS("B",DFN))&('$D(^AUPNCHS("B",DFN)))

 Q

EDCASDT ;CASE DT

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

 S DA=RD1

 S DA(1)=RD0

 S DR=".01"

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

 D ^DIE

 K DIC,DR,DIE,DA,DD,D0

 Q

EDCASTO ;ASSIGNED TO

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

 S DA=RD1

 S DA(1)=RD0

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

 S DR=".02R"

 D ^DIE

 Q:$G(X)=""!($G(X)[U)

 K DIC,DR,DIE,DA

 ;INSERT MAILMAN MESSAGE HERE

 S ALERT(0)=2

 S ALERT(1)="YOU HAVE BEEN ASSIGNED BEN. COORD. CASE # "_$G(CASENUM)

 S ALERT(2)="FOR PATIENT "_$G(AGPAT)

 S ALERT(3)="WITH CHART #: "_$G(AGCHRT)

 S ALERT(4)="BY "_$P($G(^VA(200,DUZ,0)),U)

 S XMY(X)=""

 D ALERTMSG^AGUTILS(DUZ,.XMY,"BEN COORD ASSIGNED CASE","ALERT(")

 Q

STUFFBY ;STUFF USER INITS AND USER PTR

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=".03////^S X=$P($G(^VA(200,DUZ,0)),U,2);.04////^S X=DUZ"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

STUFSTAT ;EP - STUFF STATUS IF COMPLETED BY FLD IS POPULATED

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

 S DA(1)=RD0

 S DA=RD1

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

 S DR=".07////^S X=""C"""

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDNOTES ;EP - EDIT CASE NOTES

 ;BEGIN NEW CODE AG*7.1*2 IM20457

 I $D(AGSEENLY) D  W ! K DIR S DIR(0)="E" D ^DIR Q

 .N REC S REC=0

 .F  S REC=$O(^AUPNBENR(RD0,11,RD1,1,REC)) Q:'REC  D

 ..W !,$P($G(^AUPNBENR(RD0,11,RD1,1,REC,0)),U)

 ..I $Y>($G(IOSL)-4) W ! K DIR S DIR(0)="E",DIR("A")="Press return..." D ^DIR

 ;END NEW CODE IM20457

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

 S DA(1)=RD1

 S DA(2)=RD0

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

 D EN^DIWE

 K DIC,DR,DIE,DA

 Q

 ;DISPLAY NOTES - ONLY 19 CHARS AVAILABLE TO SHOW 

GETNOTES ;EP

 N IEN

 Q:'$G(RD0)!'$G(RD1)

 Q:'$D(^AUPNBENR(RD0,11,RD1,1,0))

 ;SHORT WAY

 S IEN=$O(^AUPNBENR(RD0,11,RD1,1,0))

 ;ERROR FOUND DURING ALPHA TEST OF PATCH 1 IHS/SD/TPF 2/21/2006

 Q:'IEN

 ;END

 S LINE=$E($G(^AUPNBENR(RD0,11,RD1,1,IEN,0)),1,19)

 W LINE

 ;LONG WAY

 ;K ^UTILITY($J,"W")

 ;S DIWL=50

 ;S DIWR=75

 ;S DIWF="WC20|"

 ;S IEN=0

 ;F  S IEN=$O(^AUPNBENR(RD0,11,RD1,1,IEN)) Q:'IEN  D

 ;.S X=$G(^AUPNBENR(RD0,11,RD1,1,IEN,0))

 ;.D ^DIWP

 ;D ^DIWW

 Q

 ; ****************************************************************

 ; ON LINES BELOW:

 ; U "^" DELIMITED

 ; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'

 ; PIECE  VAR       DESC

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

 ; 1      CAPTION    FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED

 ; 2      CAPDENT    POSITION ON LINE TO DISP CAP

 ; 3      DIC        FILE OR SUBFILE #

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

 ;                   MULTIPLE FLDS TO BE PRINTED WITH THE SAME CAP AS IN

 ;                   'CITY,STATE,ZIP'

 ; 5      NEWLINE    NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#')

 ;                   USE THIS TO INDENT THE LINE

 ; 6      ITEMNUM    ITEM # ASSIGNMENT. USE THIS TO ASSIGN THE ITEM #

 ;                   USED TO ALLOW USER TO CHOOSE THIS FLD TO EDIT

 ; 7      TAGCALL    TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED

 ; 

 ; BAR "|" DELIMITED

 ; PIECE  VAR        DESC

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

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

 ;                   EXECUTED AFT FLD PRINT. IF MUTLIPLE FLDS ARE PRINTED

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

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

 ;                   PRINTING A FLD VALUE. FOR MULTIPLES SEPARATE BY ";"

 ; 4      PRECAPEX   EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.

 ;                   USE TO SCREEN OUT PRINTING A CAP/FLD LBL

 ; 5      POSTEXEC   EXECUTE CODE TO DO AFT PRINTING THE FLD DATA

 ;                   FOR MULTIPLES SEPARATE BY ";"

 ;^?0^9000044.11^.01;.02;.03;.12;.07^!^^||W "ASSIGNED TO BEN. COORD.: ";W ?45,"to ";W ?72,"by ";W !?10,"Reason: ";W ?60,"Status: "

1 ;

 ;;-                 BENEFITS COORDINATION - CASE DATA

 ;;--CASE INFORMATION---------------------------------------------------------------

 ;;Case Date^?0^9000044.11^.01^!^1^EDCASDT

 ;; by^?0^9000044.11^.03^?0^

 ;;Case Type^?0^9000044.11^.06^?50^3^EDTYPE

 ;;Case Number^?0^9000044.11^.05^!^2^EDCASNUM

 ;;Case Worker^?0^9000044.11^.08^?50^4^EDCASE

 ;;Case Reason^?0^9000044.11^.12^!^5^EDREAS

 ;;Completed By^?0^9000044.11^.09^!^6^EDCOMBY

 ;;Date^?0^9000044.11^.11^?50^^||I $D(D0) I $$GET1^DIQ(DIC,D0,.09)'=""|I $D(D0) I $$GET1^DIQ(DIC,D0,.09)'=""

 ;;Assigned to^?0^9000044.11^.02^!^7^EDCASTO|||

 ;;Notes^?0^9000044.1101^.01^?50^8^EDNOTES|||

 ;;-================================================================================

 ;;--APPLICATION--------------------------------------------------------------------

 ;;-DATE APPLICATION OBTAINED   TYPE       PERSON RECEIVING          STATUS

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

 ;;^?0^9000045.11^.01;.02;.03;.04^?0^^||W ?0;W ?28;W ?39;W ?65

 ;;-================================================================================

 ;;-SPEND DOWN INFORMATION------------------------------------------------------------

 ;;-DATE REF'ED-------FACILITY REF TO-----SPEND DOWN--LAST-ACTION-----DATE REQ'ED---

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

 ;;^?0^9000047.11^.01;.02;^?0^^||W ?0;W ?18;W ?39;W ?51;W ?67

 ;;^?0^9000047.1101^.03;.02;.01^?0^^||W ?39;W ?51;W ?67

 ;;*END*

AGEDBEB   ; IHS/ASDS/TPF - EDIT/DISP BENEFITS COORDINATOR - CASE SCREEN ;    

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

EN(RD0,RD1,NEWENTRY) ;

 +1        SET EXIT=0

 +2       ;I NEWENTRY D  Q:EXIT  S NEWENTRY=0

 +3       ;AG*7.1*2 IM22092

           IF NEWENTRY

               Begin DoDot:1

 +4                DO DRAW

                   DO WMSG

                   DO NEWENTRY

                   IF $GET(Y)<0

                       WRITE !,"No entry made"

                       HANG 2

                       SET EXIT=1

                       QUIT 

 +5                DO EDREAS

                   IF $GET(X)=""

                       DO CLEAN(RD0)

                       SET EXIT=1

                       QUIT 

 +6                DO EDCASNUM

 +7                DO EDCASTO

               End DoDot:1

               IF EXIT

                   QUIT 

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

               SET NEWENTRY=0

VAR        DO DRAW

 +1        WRITE !,AGLINE("EQ")

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

               IF (Y'?1N.N)

                   IF (Y'="E")

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

                       HANG 3

                       GOTO VAR

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

               QUIT 

 +4        KILL DIR

 +5        IF '$DATA(AGSENNLY)

               Begin DoDot:1

 +6                SET DIR("A")="Change which item (1-"_AG("N")_") OR Add <A>pplication OR Add <S>penddown information"

               End DoDot:1

 +7        IF $DATA(AGSEENLY)

               Begin DoDot:1

 +8                IF AG("N")>7

                       SET DIR("A")="Enter item number to view"

 +9                IF AG("N")<8

                       SET DIR("A")="Press return to continue"

 +10               SET DIR(0)="LO^9:"_AG("N")

               End DoDot:1

 +11       DO READ^AGED1

 +12       IF $DATA(AGSEENLY)

               IF (+Y'>0)

                   QUIT 

 +13      ;I $D(AGSEENLY),((Y<9)!(Y>AG("N"))) W !,"Enter a number between 9 and "_AG("N") H 2 G VAR

 +14      ;AG*7.1*2 IM20457;IM20809

 +15       IF $DATA(AGSEENLY)

               IF ((Y<8)!(Y>AG("N")))

                   WRITE !,"Enter a number between 8 and "_AG("N")

                   HANG 2

                   GOTO VAR

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

               GOTO END

           IF $DATA(AG("ERR"))

               GOTO VAR

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

               QUIT 

 +18       IF $GET(Y)="A"

               DO EN^AGEDBED("_AUPNPAT_","""",1,RD1)

               GOTO VAR

 +19       IF $GET(Y)="S"

               DO EN^AGEDBEH("_AUPNPAT_","""",1,RD1)

               GOTO VAR

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

               IF ('$DATA(CHOICES(+Y)))

                   WRITE !!,"You must enter a number from 1 to ",AG("N"),!,"or 'A' to add application information.",!,"or 'S' to add SPEND DOWN information"

                   HANG 3

                   GOTO VAR

 +21       IF $DATA(CHOICES(+Y))

               SET DORTN=$SELECT($PIECE(CHOICES(+Y),U)[9000045:"EN^AGEDBED",1:"EN^AGEDBEH")

               SET PARAM1=$PIECE(CHOICES(+Y),U,2)

               SET PARAM2=$PIECE(CHOICES(+Y),U,3)

               SET DORTN=DORTN_"("_PARAM1_","_PARAM2_","_"0)"

               DO @DORTN

               GOTO VAR

 +22       IF '$DATA(Y)

               QUIT 

 +23       SET AGY=Y

 +24       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")))

 +25       IF AGY=1

               IF '$DATA(^AUPNBENR(RD0,11,RD1))

                   DO CLEAN(RD0)

                   QUIT 

 +26       DO CLEAN(RD0)

           IF '$DATA(^AUPNBENR(RD0))

               QUIT 

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

 +28      ;AG*7.1*2 REPORTED DURING TESTING

           IF '$DATA(AGSEENLY)

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

 +29       KILL AGI,AGY

 +30       GOTO VAR

CLEAN(RD0) ;EP -

 +1        IF $ORDER(^AUPNBENR(RD0,11,0))=""

               Begin DoDot:1

 +2                DO CLEANZER(RD0)

 +3                WRITE !,"RECORD DELETED!"

                   HANG 3

               End DoDot:1

 +4        QUIT 

CLEANZER(RD0) ;EP

 +1        KILL DIK,DA

 +2        SET DIK="^AUPNBENR("

           SET DA=RD0

           DO ^DIK

 +3        QUIT 

END       ;CLEAN UP VARS

 +1        KILL AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC,NEWENTRY,ROUTID

 +2        QUIT 

DRAW      ;EP

 +1        KILL CHOICES

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

 +3        SET AG("PG")="5BEB"

 +4        DO ^AGED

 +5        DO GETAW

 +6        QUIT 

GETAW     ;DISP

 +1        KILL AG("C")

 +2        SET VD0=RD0

 +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 !,$EXTRACT(CAPTION,2,199)

                       QUIT 

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

 +9                SET VDR=$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 D0=RD0

 +26                       IF DIC'["."

                               SET D0=D0_","

 +27                      IF '$TEST

                               SET D0=RD1_","_D0_","

 +28                       IF DIC["9000044."

                               Begin DoDot:3

 +29                               SET D0=D0_","

 +30                               NEW PIECE

 +31                               FOR PIECE=1:1

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

                                       IF DR=""

                                           QUIT 

                                       Begin DoDot:4

 +32                                       IF $PIECE(PREEXEC,";",PIECE)'=""

                                               XECUTE $PIECE(PREEXEC,";",PIECE)

                                               IF '$TEST

                                                   QUIT 

 +33                                       IF $PIECE(EXECUTE,";",PIECE)=""

                                               WRITE $$GET1^DIQ(DIC,D0,DR)

 +34                                       IF $PIECE(EXECUTE,";",PIECE)'=""

                                               SET D0=$TRANSLATE(D0,",")

                                               XECUTE $PIECE(EXECUTE,";",PIECE)

 +35                                       IF $PIECE(POSTEXEC,";",PIECE)'=""

                                               XECUTE $PIECE(POSTEXEC,";",PIECE)

                                       End DoDot:4

 +36                               KILL PIECE

                               End DoDot:3

 +37      ;LIST OPEN APPS

                       End DoDot:2

 +38               IF DIC["9000045."

                       Begin DoDot:2

 +39                       IF NEWENTRY

                               QUIT 

 +40      ;PREV SECTION'S ITEMS END AT 8

                           SET ITEM=8

 +41                       SET VD0=$ORDER(^AUPNAPPS("B",AUPNPAT,""))

 +42                       IF VD0=""

                               WRITE !,"NO APPLICATIONS ASSOCIATED WITH THIS CASE",!

                               QUIT 

 +43                       SET CASEPTR=RD1

 +44                       SET VD0=$ORDER(^AUPNAPPS("C",CASEPTR,""))

 +45                       IF VD0=""

                               WRITE !,"NO APPLICATIONS ASSOCIATED WITH THIS CASE",!

                               QUIT 

 +46      ;GET THE APPLICATIONS BELONGING TO THIS CASE

 +47                       SET VD0=""

 +48                       FOR 

                               SET VD0=$ORDER(^AUPNAPPS("C",CASEPTR,VD0))

                               IF 'VD0

                                   QUIT 

                               Begin DoDot:3

 +49                               IF $PIECE($GET(^AUPNAPPS(VD0,0)),U)'=$GET(AUPNPAT)

                                       QUIT 

 +50                               SET BD1=0

 +51                               FOR 

                                       SET BD1=$ORDER(^AUPNAPPS("C",CASEPTR,VD0,BD1))

                                       IF 'BD1

                                           QUIT 

                                       Begin DoDot:4

 +52                                       SET ITEM=ITEM+1

 +53                                       SET CHOICES(ITEM)=DIC_U_VD0_U_BD1

 +54                                       SET D0=BD1_","_VD0_","

 +55                                       IF ITEM=1

                                               WRITE ?0,ITEM_"."

 +56                                      IF '$TEST

                                               WRITE !,ITEM_"."

 +57                                       NEW PIECE

 +58                                       FOR PIECE=1:1