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