Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGEDBEG

AGEDBEG.m

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