AGEDBEC.m

AGEDBEC ; IHS/ASDS/TPF - EDIT/DISPLAY BENEFITS COORDINATOR - AUTHORIZATIONS SCREEN ;    

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

 ;

 ;AD0 AND AD1 WILL BE THE IENS NEEDED TO DISP THE PRIOR AUTH

 ;WHICH WAS CHOSEN FROM THE BEN COORD MAIN SCREEN (^AGEDBEA)

 ;IF THIS IS A NEW ENTRY THE USER WILL BE ASKED WHAT TYPE IP/OP

EN(AD0,AD1,NEWENTRY) ;

 ;IF ITS A NEW ENTRY,DISP THE SCREEN,DISP A MESSAGE,THEN CALL THE

 ;EDITS TO FLDS APPROPRIATE FOR ADDING A NEW ENTRY

 S EXIT=0

 I NEWENTRY D DRAW,WMSG,NEWENTRY D:$G(Y)<0 BADENTRY Q:EXIT  D EDINSNAM,EDPRCERT,EDCRTNUM

 I NEWENTRY,$P($G(^AUPNAUTH(AD0,11,AD1,0)),U,3)="OP" D EDSRVCAT,EDAUTHVS S NEWENTRY=0 G VAR

 I NEWENTRY,$P($G(^AUPNAUTH(AD0,11,AD1,0)),U,3)="IP" D EDADMDT,EDAUTHDY S NEWENTRY=0

VAR D DRAW

 ;Q:$D(AGSEENLY)

 W !,AGLINE("EQ")

 K DIR

 I '$D(AGSEENLY) D

 .S DIR("A")="Change which item (1-"_AG("N")_") OR Add <A>dditional "_$S($G(TYPEFLAG)="DAYS":"Days",1:"Visits")_" or <C>ontacts"

 I $D(AGSEENLY) D

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

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

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

 D READ^AGED1

 I $D(AGSEENLY),(Y=12) D DISNOTES G VAR

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

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

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

 ;DO RTNS TO ADD ENTRY

 I $G(Y)="A"!($G(Y)="C") D @$S(Y="A":"EN^AGEDBEF("_AD0_","_AD1_","""",1)",1:"EN^AGEDBEG("_AD0_","_AD1_","""",1)") 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"),!,"or 'A' to add additional days authorized,",!,"or 'C' to add contact information." H 3 G VAR

 ;DEPENDING ON USER'S CHOICE, ITEM MAY BE AN EDIT ON THIS SCREEN OR

 ;IT MAY BE A PATIENT APPLICATION WHICH IS ON ^AGEDBED

 I $D(CHOICES(+Y)) D  G VAR

 .S DORTN=$S($P(CHOICES(+Y),U)["1201":"EN^AGEDBEF",1:"EN^AGEDBEG")

 .S PARAM1=$P(CHOICES(+Y),U,2)

 .S PARAM2=$P(CHOICES(+Y),U,3)

 .S PARAM3=$P(CHOICES(+Y),U,4)

 .S DORTN=DORTN_"("_PARAM1_","_PARAM2_","_PARAM3_","_"0)"

 .D @DORTN

 I +$G(Y) D

 .S AGY=Y

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

 ;THEY HAVE DELETED THE AUTH. ENCOUNTER DT

 ;THEY CHOSE TO ENTER THIS SCREEN. IT IS GONE

 ;SO RETURN TO MAIN SCREEN

 I AGY=1,'$D(^AUPNAUTH(AD0,11,AD1)) D CLEAN(AD0) Q

 D CLEAN(AD0) I '$D(^AUPNAUTH(AD0)) Q

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

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

 K AGI,AGY

 G VAR

CLEAN(AD0) ;CLEAN EMPTY RECORD. IF NO BEN COORD DATES HAVE BEEN

 ;ENTERED THE RECORD IS MEANINGLES

 ;

 ;CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN ENTERED. IF NOT

 ;CLEAR THE TOP LEVEL RECORD SINCE NOTHING REALLY EXISTS IN THIS RECORD

 I $O(^AUPNAUTH(AD0,11,0))="" D

 .D CLEANZER(AD0)

 .W !,"RECORD DELETED!" H 3

 Q

CLEANZER(AD0) ;EP

 K DIK,DA

 S DIK="^AUPNAUTH(",DA=AD0 D ^DIK

 Q

BADENTRY ;EP

 S EXIT=1

 W !,"Entry not made." H 2 D END Q

 Q

END ;CLEAN UP THE VARS USED

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

 K ROUTID

 Q

DRAW ;EP

 K CHOICES

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

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

 D ^AGED

 D GETAW

 Q

GETAW ;DISP

 K AG("C")

 ;S ITEM=9

 S ITEM=8  ;BAR*1.8*4 IHS/SD/TPF 3/27/08 IM28348

 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)="-" D CAPPARSE(CAPTION) Q  ;PARSE OUT CAP

 . S DIC=$P(AGSCRN,U,3)    ;FILE OR SUBFILE #

 . S DR=$P(AGSCRN,U,4)      ;FLD #

 . S SKIPEXEC=$P(AGSCRN,"|",6)  ;SKIP LOGIC. IF THIS IS TRUE WE

 . ;                             DON'T DEAL WITH THIS FLD AT ALL

 . I SKIPEXEC'="" X SKIPEXEC Q:$T

 . 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),"|",1)   ;TAG TO CALL TO EDIT THIS FLD

 . S EXECUTE=$P(AGSCRN,"|",2)      ;USE TO DISP FLD WHICH IS DEPENDENT ON OTHER 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 @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)_": ")

 .;IF EDITING,DISP DATA

 .;E DISP ONLY THE CAPS

 .I 'NEWENTRY D

 .. S D0=AD0

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

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

 .. ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP

 .. N PIECE

 .. S VDR=DR

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

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

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

 .... I DR=.08,(DIC=9000046.11),($$GET1^DIQ(DIC,D0,DR)'="") W $J($$GET1^DIQ(DIC,D0,DR),10,2) Q  ;BAR*1.8*4 IHS/SD/TPF 3/27/08 IM28348

 .... I DR=.09,(DIC=9000046.11),($$GET1^DIQ(DIC,D0,DR)'="") W $E($$GET1^DIQ(DIC,D0,DR),1,20) Q  ;BAR*1.8*4 IHS/SD/TPF 3/27/08 IM28348

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

 ..;LIST ADDITIONAL DAYS AUTHORIZED

 .. I DIC[".1201"!(DIC[".1101") D

 ... S SUBSCRIP=$S(DIC[".1201":2,1:1)

 ... S VD0=AD0

 ... S VD1=AD1

 ... I DIC[".1101",'$D(^AUPNAUTH(VD0,11,VD1,SUBSCRIP)) W !,"***NO AUTH. ENCOUNTER CONTACTS***" Q

 ... I DIC[".1201",'$D(^AUPNAUTH(VD0,11,VD1,SUBSCRIP)) W !,"***NO ADDITIONAL "_$G(TYPEFLAG)_" AUTHORIZED***" Q

 ... S VD2=0

 ... F  S VD2=$O(^AUPNAUTH(VD0,11,VD1,SUBSCRIP,VD2)) Q:'VD2  D

 .... S ITEM=ITEM+1

 .... S CHOICES(ITEM)=DIC_U_VD0_U_VD1_U_VD2

 .... S D0=VD2_","_VD1_","_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=.02:$E($$GET1^DIQ(DIC,D0,DR),1,15),DR=.04:$E($$GET1^DIQ(DIC,D0,DR),1,19),1:$$GET1^DIQ(DIC,D0,DR))

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

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

 ....K PIECE

 ..;LIST WORD PROCESSING FLDS

 ..I DIC["9000046.1301" D

 ...S ITEM=ITEM+1

 ...W !,ITEM_". NOTES: "

 ...S $P(AG("C"),",",ITEM)="EDENCNOT"

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

 ...S DIWL=12,DIWR=75

 ...S DIWF="WC65|"

 ...S VD0=AD0

 ...S VD1=AD1

 ...S VD2=0

 ...F  S VD2=$O(^AUPNAUTH(VD0,11,VD1,3,VD2)) Q:'VD2  D

 ....S X=$G(^AUPNAUTH(VD0,11,VD1,3,VD2,0))

 ....D ^DIWP

 ...D ^DIWW

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

 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)

 W $G(AGLINE("-"))

 D VERIF^AGUTILS

 Q

CAPPARSE(CAPTION) ;EP - PARSE OUT THE CAP

 N LBRACKET,RBRACKET,EXEC

 S LBRACKET="[",RBRACKET="]"

 I CAPTION'[LBRACKET W !,$E(CAPTION,2,199) Q  ;- DENOTES SIMPLE SECTION

 ;PARSE OUT AND INSERT FLD VALUES

 S FIELDS=$L(CAPTION,LBRACKET)

 W !,$E($P(CAPTION,LBRACKET),2,199)

 F PIECE=1:1:FIELDS D

 .S FIELD=$P($P(CAPTION,LBRACKET,PIECE),RBRACKET)

 .I $P(FIELD,";",3)="" W $$GET1^DIQ($P(FIELD,";"),AD1_","_AD0_",",$P(FIELD,";",2))

 .I $P(FIELD,";",3)'="" S EXEC=$P(FIELD,";",3) D

 ..S X=$$GET1^DIQ($P(FIELD,";"),AD1_","_AD0_",",$P(FIELD,";",2),"I") X EXEC

 W $P(CAPTION,RBRACKET,2)

 K LBRACKET,RBRACKET,EXEC

 Q

WMSG ;DISP THIS MSG IF THERE IS NO AUTHORIZATION DT FOUND

 W !,"You must first enter a AUTHORIZATION DATE"

 Q

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

 ; EDIT AUTHORIZATION FLDS

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

NEWENTRY ;NEW ENTRY

 W !!

 K DIC,DIE,DR,DA

 S DIC="^AUPNAUTH("

 S DIC(0)="L"

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

 S X="`"_DFN

 S TEMPDFN=DFN

 D ^DIC

 S DFN=TEMPDFN

 Q:+Y'>0

 S AD0=+Y

NEWENCDT ;ENTER NEW ENCOUNTER DT

 K DIC,DIE,DR,DA

 S DA(1)=AD0

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

 S DIC(0)="ALMEQ"

 K DD,DO

 D ^DIC

 Q:+Y'>0

 S AD1=+Y

EDENTYPE ;EDIT ENCOUNTER TYPE

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

 S DA(1)=AD0

 S DA=AD1

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

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

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDENCDT ;EDIT ENCOUNTER DT

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=".01"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDINSNAM ;EP - EDIT INSURANCE COMPANY

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=.04

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDPRCERT ;EP - EDIT PRE-CERT DT

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=".05"

 D ^DIE

 K DIC,DR,DIE,DA

 I $P($G(^AUPNAUTH(AD0,11,AD1,0)),U,5) D EDAUTHST

 Q

EDCRTNUM ;EDIT PRE-CERT #

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=.06

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDADMDT ;EDIT ADMISSION DT

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=.02

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDAUTHDY ;EDIT AUTHORIZED DAYS

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=.07

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDMAXDOL ;EDIT MAX DOLLARS

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

 S DA(1)=AD0

 S DA=AD1

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

 S DR=.08

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDSRVCAT ;EDIT SERVICE CATEGORY

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

 S DA=AD1

 S DA(1)=AD0

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

 S DR=".09"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDAUTHVS ;EDIT AUTHORIZED VISITS

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

 S DA=AD1

 S DA(1)=AD0

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

 S DR=".11"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDAUTHST ;EDIT AUTHORIZATION STATUS

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

 S DA=AD1

 S DA(1)=AD0

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

 ;IF PRE-CERT DT, MAKE AUTH STATUS REQUIRED

 I $P($G(^AUPNAUTH(AD0,11,AD1,0)),U,5) S DR=".12R",DIE("NO^")=""

 E  S DR=".12"

 D ^DIE

 K DIC,DR,DIE,DA

 Q

EDENCNOT ;EDIT ENCOUNTER NOTES

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

 S DA(1)=AD1

 S DA(2)=AD0

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

 D EN^DIWE

 K DIC,DR,DIE,DA

 Q

 ;USED ONLY FOR VIEW OPTION

DISNOTES ;EP

 I '$D(^AUPNAUTH(AD0,11,AD1,3)) W !,"NO NOTES TO VIEW" H 2 Q

 N LN,X

 S LN=0

 W !!

 F  S LN=$O(^AUPNAUTH(AD0,11,AD1,3,LN)) Q:'LN  D

 .S X=$G(^AUPNAUTH(AD0,11,AD1,3,LN,0))

 .D ^DIWP

 D ^DIWW

 K DIR S DIR(0)="E" D ^DIR

 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    POS 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 OTHER IS POINTING TO.

 ;                   EXECUTED AFT FLD PRINT. IF MUTL FILEDS 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 FIELD 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 ";"

 ; 6      SKIPEXEC   EXECUTE CODE TO SKIP ENTIRE FLD

 ;

1 ;

 ;;-                           BENEFITS COORDINATION

 ;;--[9000046.11;.03] - PRIOR AUTHORIZATIONS----------------------------------------------

 ;;Auth. Encounter Date^?0^9000046.11^.01^!^1^EDENCDT

 ;;Insurance Name^?0^9000046.11^.04^!^2^EDINSNAM

 ;;Pre-Auth Date^?0^9000046.11^.05^!^3^EDPRCERT

 ;;Pre-Auth Number^?0^9000046.11^.06^?45^4^EDCRTNUM

 ;;Admission Date^?0^9000046.11^.02^!^5^EDADMDT|||||I $$GET1^DIQ(9000046.11,AD1_","_AD0_",",.03,"I")'="IP"

 ;;Authorized Days^?0^9000046.11^.07^?45^6^EDAUTHDY|||||I $$GET1^DIQ(9000046.11,AD1_","_AD0_",",.03,"I")'="IP"

 ;;Max Dollar....^?0^9000046.11^.08^!^7^EDMAXDOL|||||I $$GET1^DIQ(9000046.11,AD1_","_AD0_",",.03,"I")'="IP"

 ;;Service Category^?0^9000046.11^.09^!^5^EDSRVCAT|||||I $$GET1^DIQ(9000046.11,AD1_","_AD0_",",.03,"I")'="OP"

 ;;Authorized Visits^?0^9000046.11^.11^?45^6^EDAUTHVS|||||I $$GET1^DIQ(9000046.11,AD1_","_AD0_",",.03,"I")'="OP"

 ;;Authorization Status^?0^9000046.11^.12^!^8^EDAUTHST

 ;;-

 ;;--CONTACT DATES------------------------------------------------------------------

 ;;-CONTACT DATE     CONTACT PERSON     PHONE           FAX          E-MAIL

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

 ;;^?0^9000046.1101^.01;.02;.03;.05;.04^?0^^||;W ?17;W ?35;W ?50;W ?60

 ;;-

 ;;--REQUEST FOR ADDITIONAL [9000046.11;.03;S TYPEFLAG=$S(X="OP":"VISITS",1:"DAYS") W TYPEFLAG] -------------------------------------------------

 ;;-Date Obtained          Reference #             Additional [9000046.11;.03;W $S(X="OP":"VISITS",1:"DAYS")] Authorized

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

 ;;^?0^9000046.1201^.01;.02;.07;.08^?0^^||;W ?25;W ?55

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

 ;;^?0^9000046.1301^.01^?0^^EDENCNOT

 ;;*END*

AGEDBEC   ; IHS/ASDS/TPF - EDIT/DISPLAY BENEFITS COORDINATOR - AUTHORIZATIONS SCREEN ;    

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

 +2       ;

 +3       ;AD0 AND AD1 WILL BE THE IENS NEEDED TO DISP THE PRIOR AUTH

 +4       ;WHICH WAS CHOSEN FROM THE BEN COORD MAIN SCREEN (^AGEDBEA)

 +5       ;IF THIS IS A NEW ENTRY THE USER WILL BE ASKED WHAT TYPE IP/OP

EN(AD0,AD1,NEWENTRY) ;

 +1       ;IF ITS A NEW ENTRY,DISP THE SCREEN,DISP A MESSAGE,THEN CALL THE

 +2       ;EDITS TO FLDS APPROPRIATE FOR ADDING A NEW ENTRY

 +3        SET EXIT=0

 +4        IF NEWENTRY

               DO DRAW

               DO WMSG

               DO NEWENTRY

               IF $GET(Y)<0

                   DO BADENTRY

               IF EXIT

                   QUIT 

               DO EDINSNAM

               DO EDPRCERT

               DO EDCRTNUM

 +5        IF NEWENTRY

               IF $PIECE($GET(^AUPNAUTH(AD0,11,AD1,0)),U,3)="OP"

                   DO EDSRVCAT

                   DO EDAUTHVS

                   SET NEWENTRY=0

                   GOTO VAR

 +6        IF NEWENTRY

               IF $PIECE($GET(^AUPNAUTH(AD0,11,AD1,0)),U,3)="IP"

                   DO EDADMDT

                   DO EDAUTHDY

                   SET NEWENTRY=0

VAR        DO DRAW

 +1       ;Q:$D(AGSEENLY)

 +2        WRITE !,AGLINE("EQ")

 +3        KILL DIR

 +4        IF '$DATA(AGSEENLY)

               Begin DoDot:1

 +5                SET DIR("A")="Change which item (1-"_AG("N")_") OR Add <A>dditional "_$SELECT($GET(TYPEFLAG)="DAYS":"Days",1:"Visits")_" or <C>ontacts"

               End DoDot:1

 +6        IF $DATA(AGSEENLY)

               Begin DoDot:1

 +7                IF AG("N")>8

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

 +8                IF AG("N")<9

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

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

               End DoDot:1

 +10       DO READ^AGED1

 +11       IF $DATA(AGSEENLY)

               IF (Y=12)

                   DO DISNOTES

                   GOTO VAR

 +12       IF $DATA(AGSEENLY)

               IF (+Y'>0)

                   QUIT 

 +13       IF $DATA(AGSEENLY)

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

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

                   HANG 2

                   GOTO VAR

 +14       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

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

               QUIT 

 +16      ;DO RTNS TO ADD ENTRY

 +17       IF $GET(Y)="A"!($GET(Y)="C")

               DO @$SELECT(Y="A":"EN^AGEDBEF("_AD0_","_AD1_","""",1)",1:"EN^AGEDBEG("_AD0_","_AD1_","""",1)")

               GOTO VAR

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

               GOTO END

           IF $DATA(AG("ERR"))

               GOTO VAR

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

               QUIT 

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

               WRITE !!,"You must enter a number from 1 to ",AG("N"),!,"or 'A' to add additional days authorized,",!,"or 'C' to add contact information."

               HANG 3

               GOTO VAR

 +21      ;DEPENDING ON USER'S CHOICE, ITEM MAY BE AN EDIT ON THIS SCREEN OR

 +22      ;IT MAY BE A PATIENT APPLICATION WHICH IS ON ^AGEDBED

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

               Begin DoDot:1

 +24               SET DORTN=$SELECT($PIECE(CHOICES(+Y),U)["1201":"EN^AGEDBEF",1:"EN^AGEDBEG")

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

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

 +27               SET PARAM3=$PIECE(CHOICES(+Y),U,4)

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

 +29               DO @DORTN

               End DoDot:1

               GOTO VAR

 +30       IF +$GET(Y)

               Begin DoDot:1

 +31               SET AGY=Y

 +32               FOR AGI=1:1

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

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

                           QUIT 

                       IF $PIECE(AG("C"),",",AG("SEL"))=""

                           QUIT 

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

               End DoDot:1

 +33      ;THEY HAVE DELETED THE AUTH. ENCOUNTER DT

 +34      ;THEY CHOSE TO ENTER THIS SCREEN. IT IS GONE

 +35      ;SO RETURN TO MAIN SCREEN

 +36       IF AGY=1

               IF '$DATA(^AUPNAUTH(AD0,11,AD1))

                   DO CLEAN(AD0)

                   QUIT 

 +37       DO CLEAN(AD0)

           IF '$DATA(^AUPNAUTH(AD0))

               QUIT 

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

 +39      ;AG*7.1*2 REPORTED DURING ALPHA

           IF '$DATA(AGSEENLY)

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

 +40       KILL AGI,AGY

 +41       GOTO VAR

CLEAN(AD0) ;CLEAN EMPTY RECORD. IF NO BEN COORD DATES HAVE BEEN

 +1       ;ENTERED THE RECORD IS MEANINGLES

 +2       ;

 +3       ;CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN ENTERED. IF NOT

 +4       ;CLEAR THE TOP LEVEL RECORD SINCE NOTHING REALLY EXISTS IN THIS RECORD

 +5        IF $ORDER(^AUPNAUTH(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="^AUPNAUTH("

           SET DA=AD0

           DO ^DIK

 +3        QUIT 

BADENTRY  ;EP

 +1        SET EXIT=1

 +2        WRITE !,"Entry not made."

           HANG 2

           DO END

           QUIT 

 +3        QUIT 

END       ;CLEAN UP THE VARS USED

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

 +2        KILL ROUTID

 +3        QUIT 

DRAW      ;EP

 +1        KILL CHOICES

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

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

 +4        DO ^AGED

 +5        DO GETAW

 +6        QUIT 

GETAW     ;DISP

 +1        KILL AG("C")

 +2       ;S ITEM=9

 +3       ;BAR*1.8*4 IHS/SD/TPF 3/27/08 IM28348

           SET ITEM=8

 +4        FOR AG=1:1

               Begin DoDot:1

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

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

                       QUIT 

 +7       ;FLD CAP

                   SET CAPTION=$PIECE(AGSCRN,U)

 +8       ;PARSE OUT CAP

                   IF $EXTRACT(CAPTION)="-"

                       DO CAPPARSE(CAPTION)

                       QUIT 

 +9       ;FILE OR SUBFILE #

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

 +10      ;FLD #

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

 +11      ;SKIP LOGIC. IF THIS IS TRUE WE

                   SET SKIPEXEC=$PIECE(AGSCRN,"|",6)

 +12      ;                             DON'T DEAL WITH THIS FLD AT ALL

 +13               IF SKIPEXEC'=""

                       XECUTE SKIPEXEC

                       IF $TEST

                           QUIT 

 +14      ;NEWLINE OR INDENT

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

 +15      ;CAP INDENT

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

 +16      ;ITEM #

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

 +17      ;TAG TO CALL TO EDIT THIS FLD

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

 +18      ;USE TO DISP FLD WHICH IS DEPENDENT ON OTHER FLD

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

 +19      ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD

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

 +20      ;PLACE CODE TO EXECUTE BEF CAP/FLD LBL

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

 +21      ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD

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

 +22      ;SELECTION STRING

                   IF TAGCALL'=""

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

 +23               WRITE @NEWLINE

 +24               WRITE ITEMNUM

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

 +26               IF PRECAPEX=""

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

 +27               IF PRECAPEX'=""

                       XECUTE PRECAPEX

                       IF $TEST

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

 +28      ;IF EDITING,DISP DATA

 +29      ;E DISP ONLY THE CAPS

 +30               IF 'NEWENTRY

                       Begin DoDot:2

 +31                       SET D0=AD0

 +32                       IF DIC'["."

                               SET D0=D0_","

 +33                      IF '$TEST

                               SET D0=AD1_","_D0_","

 +34      ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP

 +35                       NEW PIECE

 +36                       SET VDR=DR

 +37                       FOR PIECE=1:1

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

                               IF DR=""

                                   QUIT 

                               Begin DoDot:3

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

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

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

                                       Begin DoDot:4

 +40      ;BAR*1.8*4 IHS/SD/TPF 3/27/08 IM28348

                                           IF DR=.08

                                               IF (DIC=9000046.11)

                                                   IF ($$GET1^DIQ(DIC,D0,DR)'="")

                                                       WRITE $JUSTIFY($$GET1^DIQ(DIC,D0,DR),10,2)

                                                       QUIT 

 +41      ;BAR*1.8*4 IHS/SD/TPF 3/27/08 IM28348

                                           IF DR=.09

                                               IF (DIC=9000046.11)

                                                   IF ($$GET1^DIQ(DIC,D0,DR)'="")

                                                       WRITE $EXTRACT($$GET1^DIQ(DIC,D0,DR),1,20)

                                                       QUIT 

 +42                                      IF '$TEST

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

                                       End DoDot:4

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

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

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

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

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

                               End DoDot:3

 +45                       KILL PIECE

 +46      ;LIST ADDITIONAL DAYS AUTHORIZED

 +47                       IF DIC[".1201"!(DIC[".1101")

                               Begin DoDot:3

 +48                               SET SUBSCRIP=$SELECT(DIC[".1201":2,1:1)

 +49                               SET VD0=AD0

 +50                               SET VD1=AD1

 +51                               IF DIC[".1101"

                                       IF '$DATA(^AUPNAUTH(VD0,11,VD1,SUBSCRIP))

                                           WRITE !,"***NO AUTH. ENCOUNTER CONTACTS***"

                                           QUIT 

 +52                               IF DIC[".1201"

                                       IF '$DATA(^AUPNAUTH(VD0,11,VD1,SUBSCRIP))

                                           WRITE !,"***NO ADDITIONAL "_$GET(TYPEFLAG)_" AUTHORIZED***"

                                           QUIT 

 +53                               SET VD2=0

 +54                               FOR 

                                       SET VD2=$ORDER(^AUPNAUTH(VD0,11,VD1,SUBSCRIP,VD2))

                                       IF 'VD2

                                           QUIT 

                                       Begin DoDot:4

 +55                                       SET ITEM=ITEM+1