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

BSDREG.m

Go to the documentation of this file. 
  1. BSDREG ; IHS/ANMC/LJF - REG EDITS FROM SCHEDULING ; 
  1.  ;;5.3;PIMS;**1004,1006,1009**;MAY 28, 2004
  1.  ; code to return to screen (RESET) on protocol
  1.  ;IHS/OIT/LJF 07/22/2005 PATCH 1004 added ;EP to ADDRESS label; called by ^BSDWLE
  1.  ;            09/08/2006 PATCH 1006 added PEP and cleaned up call to AG PEP
  1.  ;cmi/anch/maw 02/23/2008 PATCH 1009 added code in MPH to file in OTHER PHONE (1801) field of PATIENT file
  1.  ;
  1. EN ;PEP; Edit Patient Registration using PIMS parameter rules;IHS/OIT/LJF 09/08/2006 line added
  1.  NEW BSDREG,DFN
  1.  S BSDREG=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.19,"I")  ;access level
  1.  I SDAMTYP="P" S DFN=SDFN
  1.  I SDAMTYP="C" S DFN=+$$READ^BDGF("P^2:EMQZ","Select PATIENT") Q:'DFN
  1.  D FULL^VALM1
  1.  ;
  1.  NEW AG,AGCHRT,AGLINE,AGOPT,AGPAT,AGQI,AGQT,AGSCRN,AGTP,AGUPDT
  1.  ;
  1.  ;  if turned off, display address then quit
  1.  I ('BSDREG)!(BSDREG=3&'$D(^XUSEC("SDZREGEDIT",DUZ))) D DISPLAY,PAUSE^BDGF Q
  1.  ;
  1.  ;  if address only or no key
  1.  I (BSDREG=1)!('$D(^XUSEC("SDZREGEDIT",DUZ))) D  Q
  1.  . D ADDRESS L -^AUPNPAT(DFN)
  1.  ;
  1.  ; full Registration access - first display page 11
  1.  D DISPLY11
  1.  Q:'$$READ^BDGF("Y","Want to Edit this Registration Record","NO")
  1.  ;
  1.  ;IHS/OIT/LJF 09/08/2006 PATCH 1006 cleaned up code to only call PEP
  1.  ;D ^AGVAR S X="AGEDIT" D HDR^AG
  1.  ;I $D(AGOPT(14)) D PATNLK^AGEDIT
  1.  D PATNLK^AGEDIT
  1.  Q
  1.  ;
  1. DISPLAY ; display address info only
  1.  NEW BSDR
  1.  D ENP^XBDIQ1(2,DFN,".111;.114:.116;.1219;.131;.132","BSDR(")
  1.  W !!?5,"Date of Last Registration Update: ",$$GET1^DIQ(9000001,DFN,.03)
  1.  W !!,BSDR(.111),!,BSDR(.114),", ",BSDR(.115),"  ",BSDR(.116)
  1.  W !,BSDR(.131)," (home)  ",BSDR(.132)," (work)"
  1.  I BSDR(.1219)]"" W !,BSDR(.1219)," (msg)",!!
  1.  Q
  1.  ;
  1. DISPLY11 ; display page 11 - other info
  1.  NEW X
  1.  W !!?3,$$REPEAT^XLFSTR("*",70)
  1.  W !?5,"Date of Last Registration Update: ",$$GET1^DIQ(9000001,DFN,.03)
  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. ADDRESS ;EP; edit address only  ;IHS/OIT/LJF 7/22/2005 PATCH 1004
  1.  D DISPLAY
  1.  Q:'$$READ^BDGF("Y","Does patient's address or phone # need to be updated","NO")
  1.  ;
  1. NEWADD ;EP; called by mini-registration to add address
  1.  L +^AUPNPAT(DFN):3 I '$T D  Q
  1.  . W !,*7,"Patient Entry being updated by another; try again soon."
  1.  . D PAUSE^BDGF
  1.  ;
  1.  NEW DR,SDQUIT,SDPOST,SDPRE,DIE,DA
  1. ST ; -- mailing address-street
  1.  S DR=.111 D PRESAVE,EDIT(2),POSTCK Q:$D(SDQUIT)
  1.  ;
  1. CITY ; -- mailing address-city
  1.  S DR=.114 D PRESAVE,EDIT(2),POSTCK
  1.  I SDPOST'=SDPRE D NOTE
  1.  Q:$D(DUOUT)
  1.  ;
  1. STATE ; -- mailing address-state
  1.  S DR=.115 D PRESAVE,EDIT(2),POSTCK Q:$D(SDQUIT)
  1.  ;
  1. ZIP ; -- mailing address-zip
  1.  S DR=.116 D PRESAVE,EDIT(2),POSTCK Q:$D(SDQUIT)
  1.  ;
  1. HPH ; -- home phone number
  1.  S DR=.131 D PRESAVE,EDIT(2),POSTCK Q:$D(SDQUIT)
  1.  ;
  1. WPH ; -- work phone number
  1.  S DR=.132 D PRESAVE,EDIT(2),POSTCK Q:$D(SDQUIT)
  1.  ;
  1. MPH ; -- message phone number
  1.  ;S DR=".1219T" D PRESAVE,EDIT(2),POSTCK  ;cmi/maw 2/23/2008 PATCH 1009 orig line
  1.  S DR="1801" D PRESAVEA,EDIT(9000001),POSTCKA  ;cmi/maw 2/23/2008 PATCH 1009 to update OTHER PHONE field in 9000001
  1.  W !!
  1.  Q
  1.  ;
  1. PRESAVE ; -- returns before value of data
  1.  S SDPRE=$$GET1^DIQ(2,DFN,DR)
  1.  Q
  1.  ;
  1. PRESAVEA ; -- returns before value of data
  1.  S SDPRE=$$GET1^DIQ(9000001,DFN,DR)
  1.  Q
  1.  ;
  1. POSTCK ; -- returns new value of data & sets ^agpatch if needed
  1.  NEW X
  1.  S SDPOST=$$GET1^DIQ(2,DFN,DR) I SDPOST=SDPRE Q
  1.  S X="NOW" D ^%DT S ^AGPATCH(Y,DUZ(2),DFN)=""
  1.  Q
  1.  ;
  1. POSTCKA ; -- returns new value of data & sets ^agpatch if needed
  1.  NEW X
  1.  S SDPOST=$$GET1^DIQ(9000001,DFN,DR) I SDPOST=SDPRE Q
  1.  S X="NOW" D ^%DT S ^AGPATCH(Y,DUZ(2),DFN)=""
  1.  Q
  1.  ;
  1. EDIT(FILE) ; -- edits field
  1.  S DIE=FILE,DA=DFN W ! D ^DIE S:$D(Y) SDQUIT=""
  1.  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.  Q
  1.  ;