AGEDBEG ; IHS/ASDS/TPF - EDIT/DISPLAY BENEFITS COORDINATOR - AUTHORIZATION CONTACTS SCREEN ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
;
;AD0,AD1 AND AD2 WILL BE THE IENS NEEDED TO DISP ENCOUNTER CONTACTS
;WHICH WAS CHOSEN FROM THE AUTHORIZATION SCREEN (^AGEDBEC)
EN(AD0,AD1,AD2,NEWENTRY) ;
;IF ITS A NEW ENTRY THEN DISP THE SCREEN, DISP A MSG, THEN CALL THE
;EDITS TO FLDS 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
;S EXIT=0
;I NEWENTRY D Q:EXIT S NEWENTRY=0
;.D DRAW,WMSG,NEWENTRY I $G(Y)<0 W !,"No entry made" H 2 S EXIT=1 Q
;.D EDCONPER
;.D EDCONPH
;.D EDCONFAX
;.D EDEMAIL
;
VAR S SUBS=$G(AD0)_","_$G(AD1)_","_$G(AD2)
D DRAW
;Q:$D(AGSEENLY)
W !,AGLINE("EQ")
K DIR
I '$D(AGSEENLY) D
.S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
I $D(AGSEENLY) D
.S DIR("A")="Press return to continue"
.S DIR="LO^1:"_AG("N")
D READ^AGED1
;I $D(AGSEENLY) Q
I $D(AGSEENLY),(Y=6) D DISNOTES G VAR ;AG*7.1*2 IM22306
Q:$D(AGSEENLY)
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"))
G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
Q:$D(DFOUT)!$D(DTOUT)
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 3 G VAR
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")) D @($P(AG("C"),",",AG("SEL")))
I AGY=1,'$D(^AUPNAUTH(AD0,11,AD1,1,AD2)) D CLEAN(AD0) Q ;THEY HAVE DELETED THE ENCOUNTER CONTACT DT
; THEY CHOSE TO ENTER THIS SCREEN. IT IS GONE
; SO RETURN TO MAIN SCREEN
D CLEAN(AD0)
D UPDATE1^AGED(DUZ(2),DFN,3,"")
K AGI,AGY
G VAR
CLEAN(AD0) ;CLEAN EMPTY RECORD. IF NO ENCOUNTER 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(^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
END ;CLEAN UP THE VARS
K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC,NEWENTRY
Q
DRAW ;EP
K CHOICES
D HDR
D GETAW
Q
HDR ;
S AG("PG")="5BEG" ;ENTER THIS VALUE INTO PAT REG ERROR CODES FILE
; TO MATCH UP ERRORS TO SPECIFIC SCREENS
S AGPAT=$P($G(^DPT(DFN,0)),U)
S AGCHRT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:"xxxxx")
S AG("AUPN")=""
S:$D(^AUPNPAT(DFN,0)) AG("AUPN")=^(0)
S AGLINE("-")=$TR($J(" ",78)," ","-")
S AGLINE("EQ")=$TR($J(" ",78)," ","=")
S $P(AGLINE("PGLN"),"=",81)=""
W $$S^AGVDF("IOF"),!
S ROUTID=$P($T(+1)," ")
S AG("PG")="5BEG"
D PROGVIEW^AGUTILS(DUZ,$G(SUBS))
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
W ?36,"BENEFITS COORDINATOR"
W ?80-$L($P($G(^DIC(4,DUZ(2),0)),U)),$P($G(^DIC(4,DUZ(2),0)),U)
S AGLINE("-")=$TR($J(" ",80)," ","-")
S AGLINE("EQ")=$TR($J(" ",80)," ","=")
W !,AGLINE("EQ")
W !,$E(AGPAT,1,23)
W ?23,$$DTEST^AGUTILS(DFN)
I $D(AGCHRT) W ?42,"HRN#:",AGCHRT
;GET ELIGIBILITY STATUS
S AGELSTS=$P($G(^AUPNPAT(DFN,11)),U,12)
W ?56,"(",$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
W !,AGLINE("EQ")
S DA=DFN
K AG("EDIT")
Q
GETAW ;DISP
K AG("C")
F AG=1:1 D Q:$G(AGSCRN)[("*END*")
. S AGSCRN=$P($T(@1+AG),";;",2,15)
. Q:AGSCRN[("*END*")
. S CAPTION=$P(AGSCRN,U) ;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 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 @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 ONLY
.;E DISP ONLY THE CAPS
.I 'NEWENTRY D
.. S D0=AD0
.. I DIC'["." S D0=D0_","
.. E S D0=AD2_","_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)="" 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,VDR
..I DIC["9000046.11101" D
...K ^UTILITY($J,"W")
...S DIWL=12,DIWR=75
...S DIWF="WC70|"
...S VD0=AD0
...S VD1=AD1
...S VD2=AD2
...S VD3=0
...F S VD3=$O(^AUPNAUTH(VD0,11,VD1,1,VD2,1,VD3)) Q:'VD3 D
....S X=$G(^AUPNAUTH(VD0,11,VD1,1,VD2,1,VD3,0))
....D ^DIWP
...D ^DIWW
S AG("N")=$L(AG("C"),",")
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
CAPPARSE(CAPTION) ;EP - PARSE OUT THE CAP
N LBRACKET,RBRACKET
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
Q
WMSG ;DISP THIS MSG IF THERE IS NO AUTHORIZATION DT FOUND
W !,"You must first enter a CONTACT 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
S NEWENTRY=0
ADDDT ;
K DIC,DIE,DR,DA
S DA(2)=AD0
S DA(1)=AD1
S DIC="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
S DIC(0)="ALMEQ"
K DD,DO
D ^DIC
I +Y>0 S AD2=+Y Q
Q
EDADDDT ;EDIT DT
K DIC,DR,DIE,DA,DD,DO
S DA(1)=AD1
S DA(2)=AD0
S DA=AD2
S DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
S DR=.01
D ^DIE
K DIC,DR,DIE,DA
Q
EDCONPER ;EDIT CONTACT PERSON
K DIC,DR,DIE,DA,DD,DO
S DA(1)=AD1
S DA(2)=AD0
S DA=AD2
S DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
S DR=.02
D ^DIE
K DIC,DR,DIE,DA
Q
EDCONPH ;EDIT CONTACT PHONE
K DIC,DR,DIE,DA,DD,DO
S DA(1)=AD1
S DA(2)=AD0
S DA=AD2
S DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
S DR=.03
D ^DIE
K DIC,DR,DIE,DA
Q
EDEMAIL ;EDIT CONTACT E-MAIL
K DIC,DR,DIE,DA,DD,DO
S DA(1)=AD1
S DA(2)=AD0
S DA=AD2
S DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
S DR=.04
D ^DIE
K DIC,DR,DIE,DA
Q
EDCONFAX ;EDIT CONTACT FAX
K DIC,DR,DIE,DA,DD,DO
S DA(1)=AD1
S DA(2)=AD0
S DA=AD2
S DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
S DR=.05
D ^DIE
K DIC,DR,DIE,DA
Q
EDCONNOT ;EDIT CONTACT 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(^AUPNAUTH(AD0,11,AD1,1,AD2,1,REC)) Q:'REC D
..W !,$P($G(^AUPNAUTH(AD0,11,AD1,1,AD2,1,REC,0)),U)
..I $Y>$G(IOBM) 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)=AD2
S DA(2)=AD1
S DA(3)=AD0
S DIC="^AUPNAUTH("_DA(3)_",11,"_DA(2)_",1,"_DA(1)_",1,"
D EN^DIWE
K DIC,DR,DIE,DA
Q
;USED ONLY FOR VIEW OPTION
DISNOTES ;EP
I '$D(^AUPNAUTH(AD0,11,AD1,1,AD2,1)) W !,"NO NOTES TO VIEW" H 2 Q
N LN,X
S LN=0
W !!
F S LN=$O(^AUPNAUTH(AD0,11,AD1,1,AD2,1,LN)) Q:'LN D
.S X=$G(^AUPNAUTH(AD0,11,AD1,1,AD2,1,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 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 NUMBER 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 ";"
; 6 SKIPEXEC EXECUTE CODE TO SKIP ENTIRE FLD
;
1 ;
;;--AUTHORIZATION CONTACTS---------------------------------------------------------
;;Contact Date^?0^9000046.1101^.01^!^1^EDADDDT||
;;Contact Person^?0^9000046.1101^.02^!?0^2^EDCONPER||
;;Contact Phone^?0^9000046.1101^.03^!?0^3^EDCONPH||
;;Contact Fax^?0^9000046.1101^.05^!?0^4^EDCONFAX||
;;Contact E-mail^?0^9000046.1101^.04^!?0^5^EDEMAIL||
;;--------------------------------------------------------------------------------
;;NOTES^?0^9000046.11101^.01^!^6^EDCONNOT
;;*END*
AGEDBEG ; IHS/ASDS/TPF - EDIT/DISPLAY BENEFITS COORDINATOR - AUTHORIZATION CONTACTS SCREEN ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
+2 ;
+3 ;AD0,AD1 AND AD2 WILL BE THE IENS NEEDED TO DISP ENCOUNTER CONTACTS
+4 ;WHICH WAS CHOSEN FROM THE AUTHORIZATION SCREEN (^AGEDBEC)
EN(AD0,AD1,AD2,NEWENTRY) ;
+1 ;IF ITS A NEW ENTRY THEN DISP THE SCREEN, DISP A MSG, THEN CALL THE
+2 ;EDITS TO FLDS 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 ;S NEWENTRY=0
+5 ;BELOW ASKS SEQUENCE OF QUESTIONS
+6 ;S EXIT=0
+7 ;I NEWENTRY D Q:EXIT S NEWENTRY=0
+8 ;.D DRAW,WMSG,NEWENTRY I $G(Y)<0 W !,"No entry made" H 2 S EXIT=1 Q
+9 ;.D EDCONPER
+10 ;.D EDCONPH
+11 ;.D EDCONFAX
+12 ;.D EDEMAIL
+13 ;
VAR SET SUBS=$GET(AD0)_","_$GET(AD1)_","_$GET(AD2)
+1 DO DRAW
+2 ;Q:$D(AGSEENLY)
+3 WRITE !,AGLINE("EQ")
+4 KILL DIR
+5 IF '$DATA(AGSEENLY)
Begin DoDot:1
+6 SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
End DoDot:1
+7 IF $DATA(AGSEENLY)
Begin DoDot:1
+8 SET DIR("A")="Press return to continue"
+9 SET DIR="LO^1:"_AG("N")
End DoDot:1
+10 DO READ^AGED1
+11 ;I $D(AGSEENLY) Q
+12 ;AG*7.1*2 IM22306
IF $DATA(AGSEENLY)
IF (Y=6)
DO DISNOTES
GOTO VAR
+13 IF $DATA(AGSEENLY)
QUIT
+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 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+17 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
+18 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 3
GOTO VAR
+19 IF +$GET(Y)
Begin DoDot:1
+20 SET AGY=Y
+21 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")))
End DoDot:1
+22 ;THEY HAVE DELETED THE ENCOUNTER CONTACT DT
IF AGY=1
IF '$DATA(^AUPNAUTH(AD0,11,AD1,1,AD2))
DO CLEAN(AD0)
QUIT
+23 ; THEY CHOSE TO ENTER THIS SCREEN. IT IS GONE
+24 ; SO RETURN TO MAIN SCREEN
+25 DO CLEAN(AD0)
+26 DO UPDATE1^AGED(DUZ(2),DFN,3,"")
+27 KILL AGI,AGY
+28 GOTO VAR
CLEAN(AD0) ;CLEAN EMPTY RECORD. IF NO ENCOUNTER DTS HAVE BEEN ENTERED
+1 ;THEN THE RECORD IS MEANINGLESS
+2 ;CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN ENTERED. IF NOT
+3 ;CLEAR THE RECORD SINCE NOTHING REALLY EXISTS IN THIS RECORD
+4 IF $ORDER(^AUPNAUTH(AD0,11,0))=""
Begin DoDot:1
+5 DO CLEANZER(AD0)
+6 WRITE !,"RECORD DELETED!"
HANG 3
End DoDot:1
+7 QUIT
CLEANZER(AD0) ;EP
+1 KILL DIK,DA
+2 SET DIK="^AUPNAUTH("
SET DA=AD0
DO ^DIK
+3 QUIT
END ;CLEAN UP THE VARS
+1 KILL AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT,ADFN,WDFN,REC,NEWENTRY
+2 QUIT
DRAW ;EP
+1 KILL CHOICES
+2 DO HDR
+3 DO GETAW
+4 QUIT
HDR ;
+1 ;ENTER THIS VALUE INTO PAT REG ERROR CODES FILE
SET AG("PG")="5BEG"
+2 ; TO MATCH UP ERRORS TO SPECIFIC SCREENS
+3 SET AGPAT=$PIECE($GET(^DPT(DFN,0)),U)
+4 SET AGCHRT=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),1:"xxxxx")
+5 SET AG("AUPN")=""
+6 IF $DATA(^AUPNPAT(DFN,0))
SET AG("AUPN")=^(0)
+7 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",78)," ","-")
+8 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",78)," ","=")
+9 SET $PIECE(AGLINE("PGLN"),"=",81)=""
+10 WRITE $$S^AGVDF("IOF"),!
+11 SET ROUTID=$PIECE($TEXT(+1)," ")
+12 SET AG("PG")="5BEG"
+13 DO PROGVIEW^AGUTILS(DUZ,$GET(SUBS))
+14 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+15 WRITE ?36,"BENEFITS COORDINATOR"
+16 WRITE ?80-$LENGTH($PIECE($GET(^DIC(4,DUZ(2),0)),U)),$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+17 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+18 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",80)," ","=")
+19 WRITE !,AGLINE("EQ")
+20 WRITE !,$EXTRACT(AGPAT,1,23)
+21 WRITE ?23,$$DTEST^AGUTILS(DFN)
+22 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",AGCHRT
+23 ;GET ELIGIBILITY STATUS
+24 SET AGELSTS=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+25 WRITE ?56,"(",$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
+26 WRITE !,AGLINE("EQ")
+27 SET DA=DFN
+28 KILL AG("EDIT")
+29 QUIT
GETAW ;DISP
+1 KILL AG("C")
+2 FOR AG=1:1
Begin DoDot:1
+3 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,15)
+4 IF AGSCRN[("*END*")
QUIT
+5 ;FLD CAP
SET CAPTION=$PIECE(AGSCRN,U)
+6 ;PARSE OUT CAP
IF $EXTRACT(CAPTION)="-"
DO CAPPARSE(CAPTION)
QUIT
+7 ;FILE OR SUBFILE #
SET DIC=$PIECE(AGSCRN,U,3)
+8 ;FLD #
SET DR=$PIECE(AGSCRN,U,4)
+9 ;SKIP LOGIC. IF THIS IS TRUE WE
SET SKIPEXEC=$PIECE(AGSCRN,"|",6)
+10 ; DON'T DEAL WITH THIS FLD AT ALL
+11 IF SKIPEXEC'=""
XECUTE SKIPEXEC
IF $TEST
QUIT
+12 ;NEWLINE OR INDENT
SET NEWLINE=$PIECE(AGSCRN,U,5)
+13 ;CAP INDENT
SET CAPDENT=$PIECE(AGSCRN,U,2)
+14 ;ITEM #
SET ITEMNUM=$PIECE(AGSCRN,U,6)
+15 ;TAG TO CALL TO EDIT THIS FLD
SET TAGCALL=$PIECE($PIECE(AGSCRN,U,7),"|",1)
+16 ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
SET EXECUTE=$PIECE(AGSCRN,"|",2)
+17 ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
SET PREEXEC=$PIECE(AGSCRN,"|",3)
+18 ;PLACE CODE TO EXECUTE BEF CAP/FLD LBL
SET PRECAPEX=$PIECE(AGSCRN,"|",4)
+19 ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD
SET POSTEXEC=$PIECE(AGSCRN,"|",5)
+20 ;SELECTION STRING
IF TAGCALL'=""
SET $PIECE(AG("C"),",",ITEMNUM)=TAGCALL
+21 WRITE @NEWLINE
+22 WRITE ITEMNUM
+23 WRITE $SELECT(ITEMNUM'="":". ",1:"")
+24 IF PRECAPEX=""
WRITE @CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION_": ",$GET(CAPTION)="":"",1:$PIECE($GET(^DD(DIC,DR,0)),U)_": ")
+25 IF PRECAPEX'=""
XECUTE PRECAPEX
IF $TEST
WRITE @CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION_": ",$GET(CAPTION)="":"",1:$PIECE($GET(^DD(DIC,DR,0)),U)_": ")
+26 ;IF EDITING DISP DATA ONLY
+27 ;E DISP ONLY THE CAPS
+28 IF 'NEWENTRY
Begin DoDot:2
+29 SET D0=AD0
+30 IF DIC'["."
SET D0=D0_","
+31 IF '$TEST
SET D0=AD2_","_AD1_","_D0_","
+32 ;LOOP TO HANDLE MULTIPLE DR'S FOR ONE CAP
+33 NEW PIECE
+34 SET VDR=DR
+35 FOR PIECE=1:1
SET DR=$PIECE(VDR,";",PIECE)
IF DR=""
QUIT
Begin DoDot:3
+36 IF $PIECE(PREEXEC,";",PIECE)'=""
XECUTE $PIECE(PREEXEC,";",PIECE)
+37 IF $PIECE(EXECUTE,";",PIECE)=""
WRITE $$GET1^DIQ(DIC,D0,DR)
+38 IF $PIECE(EXECUTE,";",PIECE)'=""
SET D0=$TRANSLATE(D0,",")
XECUTE $PIECE(EXECUTE,";",PIECE)
+39 IF $PIECE(POSTEXEC,";",PIECE)'=""
XECUTE $PIECE(POSTEXEC,";",PIECE)
End DoDot:3
+40 KILL PIECE,VDR
+41 IF DIC["9000046.11101"
Begin DoDot:3
+42 KILL ^UTILITY($JOB,"W")
+43 SET DIWL=12
SET DIWR=75
+44 SET DIWF="WC70|"
+45 SET VD0=AD0
+46 SET VD1=AD1
+47 SET VD2=AD2
+48 SET VD3=0
+49 FOR
SET VD3=$ORDER(^AUPNAUTH(VD0,11,VD1,1,VD2,1,VD3))
IF 'VD3
QUIT
Begin DoDot:4
+50 SET X=$GET(^AUPNAUTH(VD0,11,VD1,1,VD2,1,VD3,0))
+51 DO ^DIWP
End DoDot:4
+52 DO ^DIWW
End DoDot:3
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+53 SET AG("N")=$LENGTH(AG("C"),",")
+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
CAPPARSE(CAPTION) ;EP - PARSE OUT THE CAP
+1 NEW LBRACKET,RBRACKET
+2 SET LBRACKET="["
SET RBRACKET="]"
+3 ;- DENOTES SIMPLE SECTION
IF CAPTION'[LBRACKET
WRITE !,$EXTRACT(CAPTION,2,199)
QUIT
+4 ;PARSE OUT AND INSERT FLD VALUES
+5 SET FIELDS=$LENGTH(CAPTION,LBRACKET)
+6 WRITE !,$EXTRACT($PIECE(CAPTION,LBRACKET),2,199)
+7 FOR PIECE=1:1:FIELDS
Begin DoDot:1
+8 SET FIELD=$PIECE($PIECE(CAPTION,LBRACKET,PIECE),RBRACKET)
+9 IF $PIECE(FIELD,";",3)=""
WRITE $$GET1^DIQ($PIECE(FIELD,";"),AD1_","_AD0_",",$PIECE(FIELD,";",2))
+10 IF $PIECE(FIELD,";",3)'=""
SET EXEC=$PIECE(FIELD,";",3)
Begin DoDot:2
+11 SET X=$$GET1^DIQ($PIECE(FIELD,";"),AD1_","_AD0_",",$PIECE(FIELD,";",2),"I")
XECUTE EXEC
End DoDot:2
End DoDot:1
+12 WRITE $PIECE(CAPTION,RBRACKET,2)
+13 KILL LBRACKET,RBRACKET
+14 QUIT
WMSG ;DISP THIS MSG IF THERE IS NO AUTHORIZATION DT FOUND
+1 WRITE !,"You must first enter a CONTACT DATE"
+2 QUIT
+3 ;;;;;;;;;;;;;;;;;;;;;;;;;
+4 ; EDIT AUTHORIZATION FLDS
+5 ;;;;;;;;;;;;;;;;;;;;;;;;;
NEWENTRY ;NEW ENTRY
+1 WRITE !!
+2 KILL DIC,DIE,DR,DA
+3 SET DIC="^AUPNAUTH("
+4 SET DIC(0)="L"
+5 SET DIC("S")="I $G(Y)'=TEMPDFN"
+6 SET X="`"_DFN
+7 SET TEMPDFN=DFN
+8 DO ^DIC
+9 SET DFN=TEMPDFN
+10 IF +Y'>0
QUIT
+11 SET AD0=+Y
+12 SET NEWENTRY=0
ADDDT ;
+1 KILL DIC,DIE,DR,DA
+2 SET DA(2)=AD0
+3 SET DA(1)=AD1
+4 SET DIC="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
+5 SET DIC(0)="ALMEQ"
+6 KILL DD,DO
+7 DO ^DIC
+8 IF +Y>0
SET AD2=+Y
QUIT
+9 QUIT
EDADDDT ;EDIT DT
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=AD1
+3 SET DA(2)=AD0
+4 SET DA=AD2
+5 SET DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
+6 SET DR=.01
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
EDCONPER ;EDIT CONTACT PERSON
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=AD1
+3 SET DA(2)=AD0
+4 SET DA=AD2
+5 SET DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
+6 SET DR=.02
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
EDCONPH ;EDIT CONTACT PHONE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=AD1
+3 SET DA(2)=AD0
+4 SET DA=AD2
+5 SET DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
+6 SET DR=.03
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
EDEMAIL ;EDIT CONTACT E-MAIL
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=AD1
+3 SET DA(2)=AD0
+4 SET DA=AD2
+5 SET DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
+6 SET DR=.04
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
EDCONFAX ;EDIT CONTACT FAX
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA(1)=AD1
+3 SET DA(2)=AD0
+4 SET DA=AD2
+5 SET DIE="^AUPNAUTH("_DA(2)_",11,"_DA(1)_",1,"
+6 SET DR=.05
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
EDCONNOT ;EDIT CONTACT 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(^AUPNAUTH(AD0,11,AD1,1,AD2,1,REC))
IF 'REC
QUIT
Begin DoDot:2
+5 WRITE !,$PIECE($GET(^AUPNAUTH(AD0,11,AD1,1,AD2,1,REC,0)),U)
+6 IF $Y>$GET(IOBM)
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)=AD2
+10 SET DA(2)=AD1
+11 SET DA(3)=AD0
+12 SET DIC="^AUPNAUTH("_DA(3)_",11,"_DA(2)_",1,"_DA(1)_",1,"
+13 DO EN^DIWE
+14 KILL DIC,DR,DIE,DA
+15 QUIT
+16 ;USED ONLY FOR VIEW OPTION
DISNOTES ;EP
+1 IF '$DATA(^AUPNAUTH(AD0,11,AD1,1,AD2,1))
WRITE !,"NO NOTES TO VIEW"
HANG 2
QUIT
+2 NEW LN,X
+3 SET LN=0
+4 WRITE !!
+5 FOR
SET LN=$ORDER(^AUPNAUTH(AD0,11,AD1,1,AD2,1,LN))
IF 'LN
QUIT
Begin DoDot:1
+6 SET X=$GET(^AUPNAUTH(AD0,11,AD1,1,AD2,1,LN,0))
+7 DO ^DIWP
End DoDot:1
+8 DO ^DIWW
+9 KILL DIR
SET DIR(0)="E"
DO ^DIR
+10 QUIT
+11 ; ****************************************************************
+12 ; ON LINES BELOW:
+13 ; U "^" DELIMITED
+14 ; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
+15 ; PIECE VAR DESC
+16 ; ----- -------- -----------------------------------------------
+17 ; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
+18 ; 2 CAPDENT POSITION ON LINE TO DISP CAP
+19 ; 3 DIC FILE OR SUBFILE #
+20 ; 4 DR FLD # - THESE CAN BE SEPARATED BY ";" THIS ALLOWS
+21 ; MULTIPLE FLDS TO BE PRINTED WITH THE SAME CAP AS IN
+22 ; 'CITY,STATE,ZIP'
+23 ; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#')
+24 ; USE THIS TO INDENT THE LINE
+25 ; 6 ITEMNUM ITEM NUMBER ASSIGNMENT. USE THIS TO ASSIGN THE ITEM #
+26 ; USED TO ALLOW USER TO CHOOSE THIS FLD TO EDIT
+27 ; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
+28 ;
+29 ; BAR "|" DELIMITED
+30 ; PIECE VAR DESC
+31 ; ----- -------- ----------------------------------------------
+32 ; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO.
+33 ; EXECUTED AFT FLD PRINT. IF MUTLIPLE FLDS ARE PRINTED
+34 ; THEN MULTIPLE EXECUTE CODES CAN BE SEPARATED BY ";".
+35 ; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS. USE TO SCREEN OUT
+36 ; PRINTING A FLD VALUE. FOR MULTIPLES SEPARATE BY ";"
+37 ; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
+38 ; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
+39 ; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
+40 ; FOR MULTIPLES SEPARATE BY ";"
+41 ; 6 SKIPEXEC EXECUTE CODE TO SKIP ENTIRE FLD
+42 ;
1 ;
+1 ;;--AUTHORIZATION CONTACTS---------------------------------------------------------
+2 ;;Contact Date^?0^9000046.1101^.01^!^1^EDADDDT||
+3 ;;Contact Person^?0^9000046.1101^.02^!?0^2^EDCONPER||
+4 ;;Contact Phone^?0^9000046.1101^.03^!?0^3^EDCONPH||
+5 ;;Contact Fax^?0^9000046.1101^.05^!?0^4^EDCONFAX||
+6 ;;Contact E-mail^?0^9000046.1101^.04^!?0^5^EDEMAIL||
+7 ;;--------------------------------------------------------------------------------
+8 ;;NOTES^?0^9000046.11101^.01^!^6^EDCONNOT
+9 ;;*END*
