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

ASDREG.m

Go to the documentation of this file. 
  1. ASDREG ; IHS/ADC/PDW/ENM - REG EDITS ALLOWED FROM SCHEDULING ;  [ 12/21/1999  2:31 PM ]
  1.  ;;5.0;IHS SCHEDULING;**3,4**;MAR 25, 1999
  1.  ;PEP; called by AMER1 to edit full registration
  1.  ;
  1.  S SDSTOP=$O(^DIC(19,"B","AGEDIT",0))
  1.  I SDSTOP'="",$P(^DIC(19,SDSTOP,0),"^",3)'="" K SDSTOP Q
  1.  K SDSTOP
  1.  ;
  1.  K DIE("NO^"),SDQUIT
  1.  ;
  1. EDITYP ; -- check user for edit type to use
  1.  NEW ASDREG
  1.  S ASDREG=$$VALI^XBDIQ1(40.8,$$DIV^ASDUT,9999999.09)
  1.  I 'ASDREG D DISPLAY Q
  1.  I $D(^XUSEC("SDZREGEDIT",DUZ)),ASDREG>1 D  D END Q
  1.  . D DISREG K DIR S DIR(0)="Y",DIR("B")="NO"
  1.  . S DIR("A")="WANT TO EDIT REGISTRATION RECORD" D ^DIR K DIR
  1.  . Q:Y=0  I Y'=1 S ASDQUIT="" Q
  1.  . L +^AUPNPAT(DFN):3 I '$T D  Q
  1.  .. W !,*7,"PATIENT ENTRY LOCKED; TRY AGAIN SOON"
  1.  . S DIE=9000001,DA=DFN,DR=".14" D ^DIE L -^AUPNPAT(DFN)
  1.  . D ^AGVAR S X="AGEDIT" D HDR^AG,DISPAT
  1.  . I $D(AGOPT(14)) D PATNLK^AGEDIT ;IHS/DSD/ENM 12/21/99 RESET TO ORIG CODE. PATCH 2 CHANGE WAS INCORRECT. REQUIRES AGEDIT PATCH 4
  1.  . D ^XBCLS W !! D DISPAT W !
  1.  ;
  1. DISPLAY ;PEP; -- display address then ask to edit
  1.  ; to call at PEP have DFN set and ASDREG=1
  1.  ; if you're sure user wants to edit, set ASDOK=1
  1.  NEW ASDR D ENP^XBDIQ1(2,DFN,".111;.114:.116;.131;.132","ASDR(")
  1.  S X=$$VAL^XBDIQ1(9000001,DFN,.03) W !?5,$$FIELD(9000001,.03),":  ",X
  1.  W !!,ASDR(.111),!,ASDR(.114),", ",ASDR(.115),"  ",ASDR(.116)
  1.  W !,ASDR(.131)," (home)  ",ASDR(.132)," (work)",!!
  1.  I 'ASDREG!(ASDREG=3) D END Q
  1.  I '$G(ASDOK) D  I Y'=1 D END Q
  1.  . NEW DIR S DIR(0)="Y0",DIR("B")="NO"
  1.  . S DIR("A")="Does patient's address or phone # need to be updated"
  1.  . D ^DIR
  1.  ;
  1.  L +^AUPNPAT(DFN):3 I '$T D  D END Q
  1.  . W !,*7,"PATIENT ENTRY LOCKED; TRY AGAIN SOON"
  1.  ;
  1. ST ; -- mailing address-street
  1.  S DR=.111 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT)
  1.  ;
  1. CITY ; -- mailing address-city
  1.  S DR=.114 D PRESAVE,EDIT(2),POSTCK
  1.  I SDPOST'=SDPRE D NOTE
  1.  G END:$D(DUOUT)
  1.  ;
  1. STATE ; -- mailing address-state
  1.  S DR=.115 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT)
  1.  ;
  1. ZIP ; -- mailing address-zip
  1.  S DR=.116 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT)
  1.  ;
  1. HPH ; -- home phone number
  1.  S DR=.131 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT)
  1.  ;
  1. WPH ; -- work phone number
  1.  S DR=.132 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT) W !!
  1.  ;
  1. END ; -- eoj
  1.  L -^AUPNPAT(DFN)
  1.  K DA,DR,DIE,X,SDPOST,SDPRE,SDQUIT,ASDOK,ASDREG
  1.  K AG,AGCHRT,AGLINE,AGOPT,AGPAT,AGQI,AGQT,AGSCRN,AGTP,AGUPDT
  1.  Q
  1.  ;
  1.  ;
  1. PRESAVE ; -- SUBRTN to return before value of data
  1.  S SDPRE=$$VAL^XBDIQ1(2,DFN,DR) Q
  1.  ;
  1. POSTCK ; -- SUBRTN to return new value of data & set ^agpatch if needed
  1.  NEW X
  1.  S SDPOST=$$VAL^XBDIQ1(2,DFN,DR) I SDPOST=SDPRE Q
  1.  S X="NOW" D ^%DT S ^AGPATCH(Y,DUZ(2),DFN)=""
  1.  ;HL7 CALL
  1.  S ^XTMP("AGHL7",DFN)=DFN
  1.  Q
  1.  ;
  1. EDIT(FILE) ; -- SUBRTN to set variables
  1.  S DIE=FILE,DA=DFN W ! D ^DIE S:$D(Y) SDQUIT="" Q
  1.  ;
  1. NOTE ;
  1.  W !!?24,"Mailing address-city has changed."
  1.  W !?9,"Please check to see if Community of Residence has changed also."
  1.  W !!?20,"If Community of Residence has changed,"
  1.  W !?9,"have patient notify admitting - it affects eligibility.",! Q
  1.  ;
  1. DISPAT ; displays patient name & identifiers
  1.  NEW ASDX
  1.  S ASDX=^DPT(DFN,0)
  1.  W !!?3,$P(ASDX,U),?40,$P(ASDX,U,2) ;name,sex
  1.  W ?45,$$FMTE^XLFDT($P(ASDX,U,3),2) ;dob
  1.  W ?55,$P(ASDX,U,9) ;ssn
  1.  W ?67,$$VAL^XBDIQ1(9999999.06,DUZ(2),.08) ;facility
  1.  W ?69,$J($P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),7) ;hrcn
  1.  Q
  1.  ;
  1. DISREG ; displays last reg update and add. info
  1.  NEW X
  1.  W !!?3,$$REPEAT^XLFSTR("*",70)
  1.  S X=$$VAL^XBDIQ1(9000001,DFN,.03) W !?5,$$FIELD(9000001,.03),":  ",X
  1.  W !!?5,"Additional Registration Information:"
  1.  S X=0 F  S X=$O(^AUPNPAT(DFN,13,X)) Q:'X  D
  1.  . W !?7,^AUPNPAT(DFN,13,X,0)
  1.  W !?3,$$REPEAT^XLFSTR("*",70),!
  1.  Q
  1.  ;
  1. FIELD(X,Y) ; -- returns name of field
  1.  Q $P($G(^DD(X,Y,0)),U)