AGEDBEH ; IHS/ASDS/TPF - EDIT/DISPLAY BENEFITS COORDINATOR - SPEND DOWN INFORMATION SCREEN ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
;
;RD0 AND RD1 WILL BE THE IENS NEEDED TO DISP THE BEN COORD SPEND DOWN INFO WHICH WAS
;CHOSEN FROM THE BEN COORD CASE SCREEN (^AGEDBEB)
EN(RD0,RD1,NEWENTRY,CASEPTR) ;EP -
;IF ITS A NEW ENTRY THEN DISP THE SCREEN, DISP A MSG, THEN CALL
;THE EDITS TO FIELDS APPROPRIATE FOR ADDING A NEW ENTRY
I NEWENTRY D DRAW,WMSG,NEWENTRY I $G(Y)<0 W !,"Entry not made." H 2 D END Q
S NEWENTRY=0
;BELOW ASKS SEQUENCE OF QUESTIONS
;IF REQUESTED
;CASEPTR IS THE BACKWARD PTR TO THE 'DATE ASSIGNED' SUBSCRIPT FOR THE CASE
;THIS SPEND DOWN INFORMATION IS ASSOCIATED WITH.
;
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:Y=$G(AGOPT("ESCAPE"))
K DIR
I '$D(AGSEENLY) D
.S DIR("A")="Change which item (1-"_AG("N")_") OR <A>dd a new Date Expense Requested"
I $D(AGSEENLY) D
.S DIR("A")="Press return to continue"
D READ^AGED1
I $D(AGSEENLY) Q
G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
Q:$D(DFOUT)!$D(DTOUT)
;DO RTN'S TO ADD ENTRY
I $G(Y)="A" D ADDEXPRQ G VAR
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N")," or enter <A> to add a new 'DATE EXPENSE REQUESTED'" H 3 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(^AUPNCHS(RD0,11,RD1)) D CLEAN(RD0) Q ;THEY HAVE DELETED THE BEN. COORD. CASE DATE
; THEY CHOSE TO ENTER THIS SCREEN. IT IS GONE
; SO RETURN TO CLEANUP AND RETURN TO PREVIOUS SCREEN
D CLEAN(RD0) I '$D(^AUPNCHS(RD0)) Q
D UPDATE1^AGED(DUZ(2),DFN,3,"")
K AGI,AGY
G VAR
CLEAN(AD0) ;CLEAN EMPTY RECORD. IF NO SPEND DOWN REFERRED DTS HAVE BEEN
;ENTERED THEN THE RECORD IS MEANINGLESS
;
;CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN ENTERED. IF NOT
;CLEAR THE RECORD SINCE NOTHING REALLY EXISTS IN THIS RECORD
I $O(^AUPNCHS(AD0,11,0))="" D
.D CLEANZER(AD0)
.W !,"RECORD DELETED!" H 3
Q
CLEANZER(AD0) ;EP
K DIK,DA
S DIK="^AUPNCHS(",DA=AD0 D ^DIK
Q
END ;CLEAN UP THE VARS
K DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC,NEWENTRY
K CHOICES
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) ;FLD CAP
. I $E(CAPTION)="-" W !,$E(CAPTION,2,199) Q ;- DENOTES SECTION
. S DIC=$P(AGSCRN,U,3) ;FILE OR SUBFILE #
. S VDR=$P(AGSCRN,U,4) ;FLD #
. S NEWLINE=$P(AGSCRN,U,5) ;NEWLINE OR INDENT
. S CAPDENT=$P(AGSCRN,U,2) ;CAP INDENT
. S ITEMNUM=$P(AGSCRN,U,6) ;ITEM #
. S TAGCALL=$P($P(AGSCRN,U,7),"|") ;TAG TO CALL TO EDIT THIS FLD
. S EXECUTE=$P(AGSCRN,"|",2) ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
. S PREEXEC=$P(AGSCRN,"|",3) ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
. S PRECAPEX=$P(AGSCRN,"|",4) ;PLACE CODE TO EXECUTE BEF CAP/FLD LBL
. S POSTEXEC=$P(AGSCRN,"|",5) ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD
. S:TAGCALL'="" $P(AG("C"),",",ITEMNUM)=TAGCALL ;SELECTION STRING
. W:ITEMNUM'=3 @NEWLINE
. W:ITEMNUM'=3 ITEMNUM
. W:ITEMNUM'=3 $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)_": ")
.;IF EDITING DISP DATA ONLY
.;E DISPLAY ONLY THE CAPS
.I 'NEWENTRY D
.. S D0=RD0
.. I DIC'["." S D0=D0_","
.. E S D0=RD1_","_D0_","
.. ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP
.. I DIC=9000047.11 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)="" D
..... 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
..I DIC=9000047.1101 D
... D SPDDOWN Q
... 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)="" D
..... I DR=.03 W $J($$GET1^DIQ(DIC,D0,DR),6,2)
..... E 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
S AG("N")=ITEMNUM-1
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
SPDDOWN ;EP
S SPDDOWN=0
F S SPDDOWN=$O(^AUPNCHS(RD0,11,RD1,11,SPDDOWN)) Q:'$G(SPDDOWN) D
.S SPDDATA=$G(^AUPNCHS(RD0,11,RD1,11,SPDDOWN,0))
.S CHOICES(ITEMNUM)=RD0_U_RD1_U_SPDDOWN
.S Y=$P(SPDDATA,U) X ^DD("DD") S REQDT=Y
.W !,ITEMNUM,".",?5,REQDT,?25,$J($P(SPDDATA,U,3),8,2),?45,$P(SPDDATA,U,2)
.S $P(AG("C"),",",ITEMNUM)="EDEXPREQ"
.S ITEMNUM=ITEMNUM+1
Q
WMSG ;DISP THIS MSG IF THERE IS NO ENTRY FOUND IN SPEND DOWN INFORMATION FILE
W !,"You must first enter a SPEND DOWN REFERRAL DATE"
Q
;;;;;;;;;;;;;;;;;;;;;;;;
; EDIT SPEND DOWN REFERRAL FLDS
;;;;;;;;;;;;;;;;;;;;;;;;
NEWENTRY ;NEW ENTRY
W !!
K DIC,DIE,DR,DA
S DIC="^AUPNCHS("
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
NEWAPPDT ;
K DIC,DIE,DR,DA
S DA(1)=RD0
S DIC="^AUPNCHS("_DA(1)_",11,"
S DIC(0)="ALEMQ"
S DIC("S")="I $P(^(0),U,5)=CASEPTR"
K DD,DO
D ^DIC
Q:+Y'>0
S RD1=+Y
D STUFCASE(RD0,RD1,CASEPTR)
D ADDEXPRQ
Q
STUFCASE(RD0,RD1,CASEPTR) ;EP
K DIC,DIE,DR,DA,DIR
S DA(1)=RD0
S DA=RD1
S DIE="^AUPNCHS("_DA(1)_",11,"
S DR=".05////^S X=CASEPTR"
D ^DIE
Q
EDREFDT ;EDIT THE DT REFERRED
K DIC,DR,DIE,DA,DD,DO
S DA=RD1
S DA(1)=RD0
S DIE="^AUPNCHS("_DA(1)_",11,"
S DR=".01"
D ^DIE
K DIC,DR,DIE,DA
Q
EDACT ;EDIT THE ACTION TAKEN
I '$O(^AUPNCHS(RD0,11,RD1,11,0)) D ADDEXPRQ
K DIC,DR,DIE,DA,DD,DO
S DA(2)=RD0
S DA(1)=RD1
S DA=RD2
S DIE="^AUPNCHS("_DA(2)_",11,"_DA(1)_",11,"
S DR=.02
D ^DIE
K DIC,DR,DIE,DA
Q
EDSPDD ;EDIT SPEND DOWN
I '$O(^AUPNCHS(RD0,11,RD1,11,0)) D ADDEXPRQ
K DIC,DR,DIE,DA,DD,DO
S DA(2)=RD0
S DA(1)=RD1
S DA=RD2
S DIE="^AUPNCHS("_DA(2)_",11,"_DA(1)_",11,"
S DR=.03
D ^DIE
K DIC,DR,DIE,DA
Q
EDEXPREQ ;EDIT THE DT EXPENSE REQUESTED
I '$O(^AUPNCHS(RD0,11,RD1,11,0)) D ADDEXPRQ
K DIC,DR,DIE,DA,DD,DO
I $D(CHOICES) D
.S (DA(2),RD0)=$P(CHOICES(AGY),U)
.S (DA(1),RD1)=$P(CHOICES(AGY),U,2)
.S (DA,RD2)=$P(CHOICES(AGY),U,3)
S DA=RD2
S DIE="^AUPNCHS("_RD0_",11,"_RD1_",11,"
S DR=.01
D ^DIE
K DIC,DR,DIE,DA
D EDACT
D EDSPDD
Q
ADDEXPRQ ;EP - ADD DATE EXPENSE REQUESTED
K DIC,DIE,DR,DA,DO,DD,DIQ
S DA(2)=RD0
S DA(1)=RD1
S DIC="^AUPNCHS("_DA(2)_",11,"_DA(1)_",11,"
S DIC(0)="ALE"
K DD,DO
D ^DIC
Q:+Y'>0
S RD2=+Y
D EDACT
D EDSPDD
Q
EDREFTO ;EDIT THE REFERED TO FACILITY
K DIC,DR,DIE,DA,DD,DO
S DA=RD1
S DA(1)=RD0
S DIE="^AUPNCHS("_DA(1)_",11,"
S DR=".02"
D ^DIE
K DIC,DR,DIE,DA
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 "REFERRED TO BEN. COORD.: ";W ?45,"to ";W ?72,"by ";W !?10,"Reason: ";W ?60,"Status: "
1 ;
;;- BENEFITS COORDINATION - SPEND DOWN INFORMATION DATA
;;----SPEND DOWN INFORMATION--------------------------------------------------------
;;Date Referred^?0^9000047.11^.01^!^1^EDREFDT
;;Facility Referred to^?0^9000047.11^.02^!^2^EDREFTO
;;-
;;----DATE EXPENSE REQ'D-----SPEND DOWN---------ACTION TAKEN----------------------
;;^?0^9000047.1101^.03^?0^3^
;;*END*
;;Spend Down^?0^9000047.1101^.03^!^3^EDSPDD
;;Date Expense Requested^?0^9000047.1101^.01^?40^4^EDEXPREQ
;;Action Taken^?0^9000047.1101^.02^!^5^EDACT
;;*END*
AGEDBEH ; IHS/ASDS/TPF - EDIT/DISPLAY BENEFITS COORDINATOR - SPEND DOWN INFORMATION SCREEN ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
+2 ;
+3 ;RD0 AND RD1 WILL BE THE IENS NEEDED TO DISP THE BEN COORD SPEND DOWN INFO WHICH WAS
+4 ;CHOSEN FROM THE BEN COORD CASE SCREEN (^AGEDBEB)
EN(RD0,RD1,NEWENTRY,CASEPTR) ;EP -
+1 ;IF ITS A NEW ENTRY THEN DISP THE SCREEN, DISP A MSG, THEN CALL
+2 ;THE EDITS TO FIELDS APPROPRIATE FOR ADDING A NEW ENTRY
+3 IF NEWENTRY
DO DRAW
DO WMSG
DO NEWENTRY
IF $GET(Y)<0
WRITE !,"Entry not made."
HANG 2
DO END
QUIT
+4 SET NEWENTRY=0
+5 ;BELOW ASKS SEQUENCE OF QUESTIONS
+6 ;IF REQUESTED
+7 ;CASEPTR IS THE BACKWARD PTR TO THE 'DATE ASSIGNED' SUBSCRIPT FOR THE CASE
+8 ;THIS SPEND DOWN INFORMATION IS ASSOCIATED WITH.
+9 ;
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 Y=$GET(AGOPT("ESCAPE"))
QUIT
+4 KILL DIR
+5 IF '$DATA(AGSEENLY)
Begin DoDot:1
+6 SET DIR("A")="Change which item (1-"_AG("N")_") OR <A>dd a new Date Expense Requested"
End DoDot:1
+7 IF $DATA(AGSEENLY)
Begin DoDot:1
+8 SET DIR("A")="Press return to continue"
End DoDot:1
+9 DO READ^AGED1
+10 IF $DATA(AGSEENLY)
QUIT
+11 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+12 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
+13 ;DO RTN'S TO ADD ENTRY
+14 IF $GET(Y)="A"
DO ADDEXPRQ
GOTO VAR
+15 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")," or enter <A> to add a new 'DATE EXPENSE REQUESTED'"
HANG 3
GOTO VAR
+16 IF '$DATA(Y)
QUIT
+17 SET AGY=Y
+18 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")))
+19 ;THEY HAVE DELETED THE BEN. COORD. CASE DATE
IF AGY=1
IF '$DATA(^AUPNCHS(RD0,11,RD1))
DO CLEAN(RD0)
QUIT
+20 ; THEY CHOSE TO ENTER THIS SCREEN. IT IS GONE
+21 ; SO RETURN TO CLEANUP AND RETURN TO PREVIOUS SCREEN
+22 DO CLEAN(RD0)
IF '$DATA(^AUPNCHS(RD0))
QUIT
+23 DO UPDATE1^AGED(DUZ(2),DFN,3,"")
+24 KILL AGI,AGY
+25 GOTO VAR
CLEAN(AD0) ;CLEAN EMPTY RECORD. IF NO SPEND DOWN REFERRED DTS HAVE BEEN
+1 ;ENTERED THEN THE RECORD IS MEANINGLESS
+2 ;
+3 ;CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN ENTERED. IF NOT
+4 ;CLEAR THE RECORD SINCE NOTHING REALLY EXISTS IN THIS RECORD
+5 IF $ORDER(^AUPNCHS(AD0,11,0))=""
Begin DoDot:1
+6 DO CLEANZER(AD0)
+7 WRITE !,"RECORD DELETED!"
HANG 3
End DoDot:1
+8 QUIT
CLEANZER(AD0) ;EP
+1 KILL DIK,DA
+2 SET DIK="^AUPNCHS("
SET DA=AD0
DO ^DIK
+3 QUIT
END ;CLEAN UP THE VARS
+1 KILL DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC,NEWENTRY
+2 KILL CHOICES
+3 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 ;FLD CAP
SET CAPTION=$PIECE(AGSCRN,U)
+7 ;- DENOTES SECTION
IF $EXTRACT(CAPTION)="-"
WRITE !,$EXTRACT(CAPTION,2,199)
QUIT
+8 ;FILE OR SUBFILE #
SET DIC=$PIECE(AGSCRN,U,3)
+9 ;FLD #
SET VDR=$PIECE(AGSCRN,U,4)
+10 ;NEWLINE OR INDENT
SET NEWLINE=$PIECE(AGSCRN,U,5)
+11 ;CAP INDENT
SET CAPDENT=$PIECE(AGSCRN,U,2)
+12 ;ITEM #
SET ITEMNUM=$PIECE(AGSCRN,U,6)
+13 ;TAG TO CALL TO EDIT THIS FLD
SET TAGCALL=$PIECE($PIECE(AGSCRN,U,7),"|")
+14 ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
SET EXECUTE=$PIECE(AGSCRN,"|",2)
+15 ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
SET PREEXEC=$PIECE(AGSCRN,"|",3)
+16 ;PLACE CODE TO EXECUTE BEF CAP/FLD LBL
SET PRECAPEX=$PIECE(AGSCRN,"|",4)
+17 ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD
SET POSTEXEC=$PIECE(AGSCRN,"|",5)
+18 ;SELECTION STRING
IF TAGCALL'=""
SET $PIECE(AG("C"),",",ITEMNUM)=TAGCALL
+19 IF ITEMNUM'=3
WRITE @NEWLINE
+20 IF ITEMNUM'=3
WRITE ITEMNUM
+21 IF ITEMNUM'=3
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 EDITING DISP DATA ONLY
+25 ;E DISPLAY ONLY THE CAPS
+26 IF 'NEWENTRY
Begin DoDot:2
+27 SET D0=RD0
+28 IF DIC'["."
SET D0=D0_","
+29 IF '$TEST
SET D0=RD1_","_D0_","
+30 ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP
+31 IF DIC=9000047.11
Begin DoDot:3
+32 SET D0=D0_","
+33 NEW PIECE
+34 FOR PIECE=1:1
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:4
+35 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
IF '$TEST
QUIT
+36 IF $PIECE(EXECUTE,";",PIECE)=""
Begin DoDot:5
+37 WRITE $$GET1^DIQ(DIC,D0,DR)
End DoDot:5
+38 IF $PIECE(EXECUTE,";",PIECE)'=""
SET D0=$TRANSLATE(D0,",")
XECUTE $PIECE(EXECUTE,";",PIECE)
+39 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:4
+40 KILL PIECE
End DoDot:3
+41 IF DIC=9000047.1101
Begin DoDot:3
+42 DO SPDDOWN
QUIT
+43 SET D0=D0_","
+44 NEW PIECE
+45 FOR PIECE=1:1
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:4
+46 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
IF '$TEST
QUIT
+47 IF $PIECE(EXECUTE,";",PIECE)=""
Begin DoDot:5
+48 IF DR=.03
WRITE $JUSTIFY($$GET1^DIQ(DIC,D0,DR),6,2)
+49 IF '$TEST
WRITE $$GET1^DIQ(DIC,D0,DR)
End DoDot:5
+50 IF $PIECE(EXECUTE,";",PIECE)'=""
SET D0=$TRANSLATE(D0,",")
XECUTE $PIECE(EXECUTE,";",PIECE)
+51 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:4
+52 KILL PIECE
End DoDot:3
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+53 SET AG("N")=ITEMNUM-1
+54 WRITE !,$GET(AGLINE("-"))
+55 KILL MYERRS,MYVARS
+56 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+57 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SELECTION")=$GET(AGSELECT)
SET MYVARS("SITE")=DUZ(2)
+58 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+59 DO VERIF^AGUTILS
+60 QUIT
SPDDOWN ;EP
+1 SET SPDDOWN=0
+2 FOR
SET SPDDOWN=$ORDER(^AUPNCHS(RD0,11,RD1,11,SPDDOWN))
IF '$GET(SPDDOWN)
QUIT
Begin DoDot:1
+3 SET SPDDATA=$GET(^AUPNCHS(RD0,11,RD1,11,SPDDOWN,0))
+4 SET CHOICES(ITEMNUM)=RD0_U_RD1_U_SPDDOWN
+5 SET Y=$PIECE(SPDDATA,U)
XECUTE ^DD("DD")
SET REQDT=Y
+6 WRITE !,ITEMNUM,".",?5,REQDT,?25,$JUSTIFY($PIECE(SPDDATA,U,3),8,2),?45,$PIECE(SPDDATA,U,2)
+7 SET $PIECE(AG("C"),",",ITEMNUM)="EDEXPREQ"
+8 SET ITEMNUM=ITEMNUM+1
End DoDot:1
+9 QUIT
WMSG ;DISP THIS MSG IF THERE IS NO ENTRY FOUND IN SPEND DOWN INFORMATION FILE
+1 WRITE !,"You must first enter a SPEND DOWN REFERRAL DATE"
+2 QUIT
+3 ;;;;;;;;;;;;;;;;;;;;;;;;
+4 ; EDIT SPEND DOWN REFERRAL FLDS
+5 ;;;;;;;;;;;;;;;;;;;;;;;;
NEWENTRY ;NEW ENTRY
+1 WRITE !!
+2 KILL DIC,DIE,DR,DA
+3 SET DIC="^AUPNCHS("
+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
NEWAPPDT ;
+1 KILL DIC,DIE,DR,DA
+2 SET DA(1)=RD0
+3 SET DIC="^AUPNCHS("_DA(1)_",11,"
+4 SET DIC(0)="ALEMQ"
+5 SET DIC("S")="I $P(^(0),U,5)=CASEPTR"
+6 KILL DD,DO
+7 DO ^DIC
+8 IF +Y'>0
QUIT
+9 SET RD1=+Y
+10 DO STUFCASE(RD0,RD1,CASEPTR)
+11 DO ADDEXPRQ
+12 QUIT
STUFCASE(RD0,RD1,CASEPTR) ;EP
+1 KILL DIC,DIE,DR,DA,DIR
+2 SET DA(1)=RD0
+3 SET DA=RD1
+4 SET DIE="^AUPNCHS("_DA(1)_",11,"
+5 SET DR=".05////^S X=CASEPTR"
+6 DO ^DIE
+7 QUIT
EDREFDT ;EDIT THE DT REFERRED
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=RD1
+3 SET DA(1)=RD0
+4 SET DIE="^AUPNCHS("_DA(1)_",11,"
+5 SET DR=".01"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
EDACT ;EDIT THE ACTION TAKEN
+1 IF '$ORDER(^AUPNCHS(RD0,11,RD1,11,0))
DO ADDEXPRQ
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA(2)=RD0
+4 SET DA(1)=RD1
+5 SET DA=RD2
+6 SET DIE="^AUPNCHS("_DA(2)_",11,"_DA(1)_",11,"
+7 SET DR=.02
+8 DO ^DIE
+9 KILL DIC,DR,DIE,DA
+10 QUIT
EDSPDD ;EDIT SPEND DOWN
+1 IF '$ORDER(^AUPNCHS(RD0,11,RD1,11,0))
DO ADDEXPRQ
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA(2)=RD0
+4 SET DA(1)=RD1
+5 SET DA=RD2
+6 SET DIE="^AUPNCHS("_DA(2)_",11,"_DA(1)_",11,"
+7 SET DR=.03
+8 DO ^DIE
+9 KILL DIC,DR,DIE,DA
+10 QUIT
EDEXPREQ ;EDIT THE DT EXPENSE REQUESTED
+1 IF '$ORDER(^AUPNCHS(RD0,11,RD1,11,0))
DO ADDEXPRQ
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 IF $DATA(CHOICES)
Begin DoDot:1
+4 SET (DA(2),RD0)=$PIECE(CHOICES(AGY),U)
+5 SET (DA(1),RD1)=$PIECE(CHOICES(AGY),U,2)
+6 SET (DA,RD2)=$PIECE(CHOICES(AGY),U,3)
End DoDot:1
+7 SET DA=RD2
+8 SET DIE="^AUPNCHS("_RD0_",11,"_RD1_",11,"
+9 SET DR=.01
+10 DO ^DIE
+11 KILL DIC,DR,DIE,DA
+12 DO EDACT
+13 DO EDSPDD
+14 QUIT
ADDEXPRQ ;EP - ADD DATE EXPENSE REQUESTED
+1 KILL DIC,DIE,DR,DA,DO,DD,DIQ
+2 SET DA(2)=RD0
+3 SET DA(1)=RD1
+4 SET DIC="^AUPNCHS("_DA(2)_",11,"_DA(1)_",11,"
+5 SET DIC(0)="ALE"
+6 KILL DD,DO
+7 DO ^DIC
+8 IF +Y'>0
QUIT
+9 SET RD2=+Y
+10 DO EDACT
+11 DO EDSPDD
+12 QUIT
EDREFTO ;EDIT THE REFERED TO FACILITY
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=RD1
+3 SET DA(1)=RD0
+4 SET DIE="^AUPNCHS("_DA(1)_",11,"
+5 SET DR=".02"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
+9 ; ****************************************************************
+10 ; ON LINES BELOW:
+11 ; U "^" DELIMITED
+12 ; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
+13 ; PIECE VAR DESC
+14 ; ----- -------- -----------------------------------------------
+15 ; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
+16 ; 2 CAPDENT POSITION ON LINE TO DISP CAP
+17 ; 3 DIC FILE OR SUBFILE #
+18 ; 4 DR FLD # - THESE CAN BE SEPARATED BY ";" THIS ALLOWS
+19 ; MULTIPLE FLDS TO BE PRINTED WITH THE SAME CAP AS IN
+20 ; 'CITY,STATE,ZIP'
+21 ; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#')
+22 ; USE THIS TO INDENT THE LINE
+23 ; 6 ITEMNUM ITEM # ASSIGNMENT. USE THIS TO ASSIGN THE ITEM #
+24 ; USED TO ALLOW USER TO CHOOSE THIS FLD TO EDIT
+25 ; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
+26 ;
+27 ; BAR "|" DELIMITED
+28 ; PIECE VAR DESC
+29 ; ----- -------- ----------------------------------------------
+30 ; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO.
+31 ; EXECUTED AFT FLD PRINT. IF MUTLIPLE FLDS ARE PRINTED
+32 ; THEN MULTIPLE EXECUTE CODES CAN BE SEPARATED BY ";".
+33 ; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS. USE TO SCREEN OUT
+34 ; PRINTING A FLD VALUE. FOR MULTIPLES SEPARATE BY ";"
+35 ; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
+36 ; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
+37 ; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
+38 ; FOR MULTIPLES SEPARATE BY ";"
+39 ;^?0^9000044.11^.01;.02;.03;.12;.07^!^^||W "REFERRED TO BEN. COORD.: ";W ?45,"to ";W ?72,"by ";W !?10,"Reason: ";W ?60,"Status: "
1 ;
+1 ;;- BENEFITS COORDINATION - SPEND DOWN INFORMATION DATA
+2 ;;----SPEND DOWN INFORMATION--------------------------------------------------------
+3 ;;Date Referred^?0^9000047.11^.01^!^1^EDREFDT
+4 ;;Facility Referred to^?0^9000047.11^.02^!^2^EDREFTO
+5 ;;-
+6 ;;----DATE EXPENSE REQ'D-----SPEND DOWN---------ACTION TAKEN----------------------
+7 ;;^?0^9000047.1101^.03^?0^3^
+8 ;;*END*
+9 ;;Spend Down^?0^9000047.1101^.03^!^3^EDSPDD
+10 ;;Date Expense Requested^?0^9000047.1101^.01^?40^4^EDEXPREQ
+11 ;;Action Taken^?0^9000047.1101^.02^!^5^EDACT
+12 ;;*END*
