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
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:5
+59 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
+60 IF $PIECE(EXECUTE,";",PIECE)=""
Begin DoDot:6
+61 WRITE $SELECT(DR=.03:$EXTRACT($$GET1^DIQ(DIC,D0,DR),1,20),1:$$GET1^DIQ(DIC,D0,DR))
End DoDot:6
+62 IF $PIECE(EXECUTE,";",PIECE)'=""
XECUTE $PIECE(EXECUTE,";",PIECE)
+63 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:5
+64 KILL PIECE
End DoDot:4
End DoDot:3
End DoDot:2
+65 IF DIC=9000044.1101
IF NEWENTRY
QUIT
DO GETNOTES
+66 IF DIC="9000047.11"
Begin DoDot:2
+67 IF NEWENTRY
QUIT
+68 SET VD0=$ORDER(^AUPNCHS("B",AUPNPAT,""))
+69 IF VD0=""
WRITE !,"NO SPEND DOWN INFORMATION ASSOCIATED WITH THIS CASE",!
QUIT
+70 ;GET THE SPEND DOWN INFO BELONGING TO THIS CASE
+71 SET CASEPTR=RD1
+72 SET VD0=$ORDER(^AUPNCHS("C",CASEPTR,""))
+73 IF VD0=""
WRITE !,"NO SPEND DOWN INFORMATION ASSOCIATED WITH THIS CASE",!
QUIT
+74 SET VD0=""
+75 FOR
SET VD0=$ORDER(^AUPNCHS("C",CASEPTR,VD0))
IF 'VD0
QUIT
Begin DoDot:3
+76 IF $PIECE($GET(^AUPNCHS(VD0,0)),U)'=$GET(AUPNPAT)
QUIT
+77 SET BD1=0
+78 FOR
SET BD1=$ORDER(^AUPNCHS("C",CASEPTR,VD0,BD1))
IF 'BD1
QUIT
Begin DoDot:4
+79 SET ITEM=ITEM+1
+80 SET CHOICES(ITEM)=DIC_U_VD0_U_BD1
+81 SET D0=BD1_","_VD0_","
+82 IF ITEM=1
WRITE ?0,ITEM_"."
+83 IF '$TEST
WRITE !,ITEM_"."
+84 NEW PIECE
+85 FOR PIECE=1:1
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:5
+86 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
+87 IF $PIECE(EXECUTE,";",PIECE)=""
Begin DoDot:6
+88 WRITE $SELECT(DR=.04:$JUSTIFY($$GET1^DIQ(DIC,D0,DR),6,2),(DR=.02!(DR=.03)):$EXTRACT($$GET1^DIQ(DIC,D0,DR),1,15),1:$$GET1^DIQ(DIC,D0,DR))
End DoDot:6
+89 IF $PIECE(EXECUTE,";",PIECE)'=""
XECUTE $PIECE(EXECUTE,";",PIECE)
+90 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:5
+91 KILL PIECE
+92 DO SPENDOWN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+93 SET AG("N")=$GET(ITEM)
+94 WRITE !,$GET(AGLINE("-"))
+95 KILL MYERRS,MYVARS
+96 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+97 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+98 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+99 DO VERIF^AGUTILS
+100 QUIT
SPENDOWN ;EP - GET SPEND DOWNS FOR THE DATE REFERRED
+1 SET LSTONE=$ORDER(^AUPNCHS(VD0,11,BD1,11,"B"),-1)
+2 SET SPDDATA=$GET(^AUPNCHS(VD0,11,BD1,11,LSTONE,0))
+3 SET Y=$PIECE(SPDDATA,U)
XECUTE ^DD("DD")
SET SPDDATE=Y
+4 WRITE ?39,$JUSTIFY($PIECE(SPDDATA,U,3),8,2),?51,$PIECE(SPDDATA,U,2),?67,SPDDATE
+5 QUIT
WMSG ;DISP MSG IF NO ENTRY IS FOUND IN ANY OF THE GUARAN
+1 ;FILES (EMPLOYER, PATIENT, INSURER)
+2 WRITE !,"You must first enter a BENEFIT CASE DATE"
+3 QUIT
+4 ;;;;;;;;;;;;;;;;;;;;;;;
+5 ;EDIT BENEFIT CASE FLDS
+6 ;;;;;;;;;;;;;;;;;;;;;;;
+7 ;
NEWENTRY ;NEW ENTRY
+1 WRITE !!
+2 KILL DIC,DIE,DR,DA
+3 SET DIC="^AUPNBENR("
+4 SET DIC(0)="L"
+5 SET X="`"_DFN
+6 SET DIC("S")="I $G(Y)'=TEMPDFN"
+7 SET TEMPDFN=DFN
+8 DO ^DIC
+9 SET DFN=TEMPDFN
+10 IF +Y<0
QUIT
+11 SET RD0=+Y
+12 SET NEWENTRY=0
NEWCASDT ;
+1 KILL DIC,DIE,DR,DA
+2 SET DA(1)=RD0
+3 SET DIC="^AUPNBENR("_DA(1)_",11,"
+4 SET DIC(0)="ALMEQ"
+5 SET DIC("S")="I $P(^(0),U,7)'=""C"""
+6 KILL DD,DO
+7 DO ^DIC
+8 IF +Y>0
SET RD1=+Y
DO STUFFBY
QUIT
+9 QUIT
EDCOMBY ;EP - COMPLETED BY
+1 ;CHK TO SEE IF THERE ARE ANY MORE OPEN CASES AVAILABLE.
+2 ;IF NOT, DO NOT ALLOW CLOSING?
+3 ;REMOVE RESTRICTION ON CLOSING CASES IM20027,IM20008 AG*7.1*1
+4 ;I '$$ENUFOPEN(RD0) W !,"CANNOT DELETE THIS OPEN CASE - PATIENT HAS APPLICATIONS AND SPEND DOWN INFORMATION!" H 2 Q
+5 KILL DIC,DR,DIE,DA,DD,DO
+6 SET DA(1)=RD0
+7 SET DA=RD1
+8 SET DIE="^AUPNBENR("_DA(1)_",11,"
+9 SET DR=.09
+10 DO ^DIE
+11 IF $GET(X)'=""
IF ($GET(X)'[U)
DO STUFSTAT
DO EDDTCOM
+12 KILL DIC,DR,DIE,DA
+13 QUIT
ENUFOPEN(RD0) ;EP - IF NO APPS OR SPEND DOWN INFO, OK TO DELETE
+1 IF $$NOAPSCHS(DFN)
QUIT 1
+2 NEW REC,OPEN
+3 SET OPEN=0
+4 SET REC=0
+5 FOR
SET REC=$ORDER(^AUPNBENR(RD0,11,REC))
IF 'REC
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNBENR(RD0,11,REC,0),U,7)'="C"
SET OPEN=OPEN+1
End DoDot:1
+7 IF '(OPEN>1)
WRITE !,"CANNOT DELETE THIS OPEN CASE - PATIENT HAS APPLICATIONS AND SPEND DOWN INFORMATION!"
+8 QUIT OPEN>1
EDDTCOM ;EP - DT COMPLETED
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=".11R"
+6 SET DIE("NO^")=""
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
EDREAS ;CASE REASON
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=".12R"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
EDCASE ;CASE WORKER
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=.08
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
EDCASNUM ;CASE #
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=.05
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
EDTYPE ;CASE TYPE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=.06
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
NODELALL(RD0) ;EP
+1 ;IF NO APPS OR SPEND DOWN INFO, IT'S OK TO DELETE
+2 IF $$NOAPSCHS(DFN)
QUIT 0
+3 ;MUST HAVE AT LEAST ONE "OPEN" CASE SO USER CAN ACCESS THE APPS
+4 ;AND SPEND DOWN INFO
+5 NEW NODELALL
+6 SET NODELALL=0
+7 ;DO WE HAVE AT LEAST ONE ENTRY?
IF $ORDER(^AUPNBENR(RD0,11,0))
Begin DoDot:1
+8 ;IF TRUE, THERE'S ONE ENTRY LEFT AND WE CANNOT DELETE.
IF $ORDER(^AUPNBENR(RD0,11,0))=$ORDER(^AUPNBENR(RD0,11,"B"),-1)
Begin DoDot:2
+9 SET NODELALL=1
+10 WRITE !,"CANNOT DELETE THIS DATE BECAUSE YOU HAVE APPLICATION AND SPEND DOWN INFORMATION CONNECTED TO IT!!"
HANG 2
End DoDot:2
End DoDot:1
+11 ;MUST RETURN TRUE TO WORK WITH "DEL" NODE LOGIC IN ^DD
QUIT NODELALL
NOAPSCHS(DFN) ;EP
+1 ;ARE THERE APPS OR SPEND DOWN INFO FOR THIS PAT?
+2 QUIT '$DATA(^AUPNAPPS("B",DFN))&('$DATA(^AUPNCHS("B",DFN)))
+3 QUIT
EDCASDT ;CASE DT
+1 KILL DIC,DR,DIE,DA,DD,DO,DIR,DIDEL
+2 SET DA=RD1
+3 SET DA(1)=RD0
+4 SET DR=".01"
+5 SET DIE="^AUPNBENR("_DA(1)_",11,"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA,DD,D0
+8 QUIT
EDCASTO ;ASSIGNED TO
+1 KILL DIC,DR,DIE,DA,DD,DO,ALERT
+2 SET DA=RD1
+3 SET DA(1)=RD0
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=".02R"
+6 DO ^DIE
+7 IF $GET(X)=""!($GET(X)[U)
QUIT
+8 KILL DIC,DR,DIE,DA
+9 ;INSERT MAILMAN MESSAGE HERE
+10 SET ALERT(0)=2
+11 SET ALERT(1)="YOU HAVE BEEN ASSIGNED BEN. COORD. CASE # "_$GET(CASENUM)
+12 SET ALERT(2)="FOR PATIENT "_$GET(AGPAT)
+13 SET ALERT(3)="WITH CHART #: "_$GET(AGCHRT)
+14 SET ALERT(4)="BY "_$PIECE($GET(^VA(200,DUZ,0)),U)
+15 SET XMY(X)=""
+16 DO ALERTMSG^AGUTILS(DUZ,.XMY,"BEN COORD ASSIGNED CASE","ALERT(")
+17 QUIT
STUFFBY ;STUFF USER INITS AND USER PTR
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=".03////^S X=$P($G(^VA(200,DUZ,0)),U,2);.04////^S X=DUZ"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
STUFSTAT ;EP - STUFF STATUS IF COMPLETED BY FLD IS POPULATED
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNBENR("_DA(1)_",11,"
+5 SET DR=".07////^S X=""C"""
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
EDNOTES ;EP - EDIT CASE NOTES
+1 ;BEGIN NEW CODE AG*7.1*2 IM20457
+2 IF $DATA(AGSEENLY)
Begin DoDot:1
+3 NEW REC
SET REC=0
+4 FOR
SET REC=$ORDER(^AUPNBENR(RD0,11,RD1,1,REC))
IF 'REC
QUIT
Begin DoDot:2
+5 WRITE !,$PIECE($GET(^AUPNBENR(RD0,11,RD1,1,REC,0)),U)
+6 IF $Y>($GET(IOSL)-4)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press return..."
DO ^DIR
End DoDot:2
End DoDot:1
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
QUIT
+7 ;END NEW CODE IM20457
+8 KILL DIC,DR,DIE,DA,DD,DO
+9 SET DA(1)=RD1
+10 SET DA(2)=RD0
+11 SET DIC="^AUPNBENR("_DA(2)_",11,"_DA(1)_",1,"
+12 DO EN^DIWE
+13 KILL DIC,DR,DIE,DA
+14 QUIT
+15 ;DISPLAY NOTES - ONLY 19 CHARS AVAILABLE TO SHOW
GETNOTES ;EP
+1 NEW IEN
+2 IF '$GET(RD0)!'$GET(RD1)
QUIT
+3 IF '$DATA(^AUPNBENR(RD0,11,RD1,1,0))
QUIT
+4 ;SHORT WAY
+5 SET IEN=$ORDER(^AUPNBENR(RD0,11,RD1,1,0))
+6 ;ERROR FOUND DURING ALPHA TEST OF PATCH 1 IHS/SD/TPF 2/21/2006
+7 IF 'IEN
QUIT
+8 ;END
+9 SET LINE=$EXTRACT($GET(^AUPNBENR(RD0,11,RD1,1,IEN,0)),1,19)
+10 WRITE LINE
+11 ;LONG WAY
+12 ;K ^UTILITY($J,"W")
+13 ;S DIWL=50
+14 ;S DIWR=75
+15 ;S DIWF="WC20|"
+16 ;S IEN=0
+17 ;F S IEN=$O(^AUPNBENR(RD0,11,RD1,1,IEN)) Q:'IEN D
+18 ;.S X=$G(^AUPNBENR(RD0,11,RD1,1,IEN,0))
+19 ;.D ^DIWP
+20 ;D ^DIWW
+21 QUIT
+22 ; ****************************************************************
+23 ; ON LINES BELOW:
+24 ; U "^" DELIMITED
+25 ; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
+26 ; PIECE VAR DESC
+27 ; ----- -------- -----------------------------------------------
+28 ; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
+29 ; 2 CAPDENT POSITION ON LINE TO DISP CAP
+30 ; 3 DIC FILE OR SUBFILE #
+31 ; 4 DR FLD # - THESE CAN BE SEPARATED BY ";" THIS ALLOWS
+32 ; MULTIPLE FLDS TO BE PRINTED WITH THE SAME CAP AS IN
+33 ; 'CITY,STATE,ZIP'
+34 ; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#')
+35 ; USE THIS TO INDENT THE LINE
+36 ; 6 ITEMNUM ITEM # ASSIGNMENT. USE THIS TO ASSIGN THE ITEM #
+37 ; USED TO ALLOW USER TO CHOOSE THIS FLD TO EDIT
+38 ; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
+39 ;
+40 ; BAR "|" DELIMITED
+41 ; PIECE VAR DESC
+42 ; ----- -------- ----------------------------------------------
+43 ; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO.
+44 ; EXECUTED AFT FLD PRINT. IF MUTLIPLE FLDS ARE PRINTED
+45 ; THEN MULTIPLE EXECUTE CODES CAN BE SEPARATED BY ";".
+46 ; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS. USE TO SCREEN OUT
+47 ; PRINTING A FLD VALUE. FOR MULTIPLES SEPARATE BY ";"
+48 ; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
+49 ; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
+50 ; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
+51 ; FOR MULTIPLES SEPARATE BY ";"
+52 ;^?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 ;
+1 ;;- BENEFITS COORDINATION - CASE DATA
+2 ;;--CASE INFORMATION---------------------------------------------------------------
+3 ;;Case Date^?0^9000044.11^.01^!^1^EDCASDT
+4 ;; by^?0^9000044.11^.03^?0^
+5 ;;Case Type^?0^9000044.11^.06^?50^3^EDTYPE
+6 ;;Case Number^?0^9000044.11^.05^!^2^EDCASNUM
+7 ;;Case Worker^?0^9000044.11^.08^?50^4^EDCASE
+8 ;;Case Reason^?0^9000044.11^.12^!^5^EDREAS
+9 ;;Completed By^?0^9000044.11^.09^!^6^EDCOMBY
+10 ;;Date^?0^9000044.11^.11^?50^^||I $D(D0) I $$GET1^DIQ(DIC,D0,.09)'=""|I $D(D0) I $$GET1^DIQ(DIC,D0,.09)'=""
+11 ;;Assigned to^?0^9000044.11^.02^!^7^EDCASTO|||
+12 ;;Notes^?0^9000044.1101^.01^?50^8^EDNOTES|||
+13 ;;-================================================================================
+14 ;;--APPLICATION--------------------------------------------------------------------
+15 ;;-DATE APPLICATION OBTAINED TYPE PERSON RECEIVING STATUS
+16 ;;---------------------------------------------------------------------------------
+17 ;;^?0^9000045.11^.01;.02;.03;.04^?0^^||W ?0;W ?28;W ?39;W ?65
+18 ;;-================================================================================
+19 ;;-SPEND DOWN INFORMATION------------------------------------------------------------
+20 ;;-DATE REF'ED-------FACILITY REF TO-----SPEND DOWN--LAST-ACTION-----DATE REQ'ED---
+21 ;;---------------------------------------------------------------------------------
+22 ;;^?0^9000047.11^.01;.02;^?0^^||W ?0;W ?18;W ?39;W ?51;W ?67
+23 ;;^?0^9000047.1101^.03;.02;.01^?0^^||W ?39;W ?51;W ?67
+24 ;;*END*
