DVBCADR ;ALB/JLU-editing the address ;1/28/93
;;2.7;AMIE;**19**;Apr 10, 1995
;
EN ;driver of the program
S DVBCSTP=0
F DO Q:DVBCSTP
.D PAT Q:DVBCSTP
.D INIT Q:DVBCSTP
.F D GUTS Q:DVBCSTP1
.I DVBCMAL D MAIL
D EXIT
Q
;
GUTS ;this is the interloop or guts of the driver
D DISPL
D ASK
I 'Y S DVBCSTP1=1 Q
D QUES^DGRPU1(DVBCDFN,"ADD1")
I DGERR D ERROR Q
I DGCHANGE S DVBCMAL=1
D VDPTP
Q
;
EXIT ;cleans variables
K %H,DFN,DGCHANGE,DGERR,DIC,DIR,DVBC,DVBCDATE,DVBCDFN,DVBCLINE,DVBCMAL,DVBCPATN,DVBCSSN,DVBCSTP,DVBCSTP1,VAERR,VAPA,Y,XMTEXT,XMY,XMB,XMDUZ,XMSUB,DVBCX,DVBCML,DVBCSP,DVBCSP1,ER,J,C,PNAM,SSN,DVBCSSNO
K DVBTMP,XMBTEXT
Q
;
ERROR ;this is an erro printing subroutine
I DGERR W !,*7
Q
;
INIT ;initialize variables
I '$D(IOF) D HOME^%ZIS
K VAPA,DVBTMP,DVBC
S %H=$H
D YX^%DTC
S DVBCDATE=$P(Y,"@",1)
S $P(DVBCLINE,"_",80)=""
S SSN=$P(^DPT(DVBCDFN,0),U,9)
D SSNOUT^DVBCUTIL
S DVBCSSN=DVBCSSNO
D VDPTTMP
I VAERR S DVBCSTP=1 Q
I +VAPA(9) DO
.D STORTMP
.K VAPA
.D VDPTP
I VAERR S DVBCSTP=1 Q
D STORE
S (DVBCSTP1,DVBCMAL)=0
Q
;
PAT ;get the patient
S DIC="^DPT(",DIC(0)="AEMQ"
D ^DIC
I Y<0 S DVBCSTP=1 Q
S DVBCDFN=+Y,(PNAM,DVBCPATN)=$P(Y,U,2)
Q
;
DISPL ;the display subroutine
W @IOF
W "Edit Address Information",?35,$$SITE^DVBCUTL4,?67,DVBCDATE
W !,"Name: ",DVBCPATN,?54,"SSN: ",DVBCSSN
W !,DVBCLINE
W !,?9,"Permanent"
I $D(DVBTMP) DO
.W ?40,"Temporary: ",$P(DVBTMP(9),U,2)
.I $P(DVBTMP(10),U,2)]"" W " to ",$P(DVBTMP(10),U,2)
W !,"Address: ",$E(VAPA(1),1,29)
I $D(DVBTMP) W ?40,$E(DVBTMP(1),1,29)
W !,?9,$E(VAPA(2),1,29)
I $D(DVBTMP) W ?40,$E(DVBTMP(2),1,29)
W !,?9,$E(VAPA(3),1,29)
I $D(DVBTMP) W ?40,$E(DVBTMP(3),1,29)
W !,"City:",?9,VAPA(4)
I $D(DVBTMP) W ?40,DVBTMP(4)
W !,"State:",?9,$P(VAPA(5),U,2)
I $D(DVBTMP) W ?40,$P(DVBTMP(5),U,2)
W !,"Zip+4:",?9,$S($D(VAPA(11)):$P(VAPA(11),"^",2),1:"")
I $D(DVBTMP) W ?40,DVBTMP(11)
W !,"County:",?9,$P(VAPA(7),U,2)
I $D(DVBTMP) W ?40,$P(DVBTMP(7),U,2)
W !,"Phone:",?9,VAPA(8)
I $D(DVBTMP) W ?40,DVBTMP(8)
W !,"Office:",?9,VAPA(9999)
W !,DVBCLINE
Q
;
ASK ;ask if yes or no
S DIR(0)="Y",DIR("A")="Do you wish to edit this address:",DIR("B")="YES"
D ^DIR
Q
;
STORE ;store original address fro possible bulletin
S DVBC(1)=VAPA(1),DVBC(2)=VAPA(2),DVBC(3)=VAPA(3)
S DVBC(4)=VAPA(4),DVBC(5)=$P(VAPA(5),U,2)
S DVBC(11)=$S($D(VAPA(11)):$P(VAPA(11),"^",2),1:"")
S DVBC(7)=$P(VAPA(7),U,2),DVBC(8)=VAPA(8)
S DVBC(9999)=VAPA(9999)
Q
;
VDPTP ;gets the permanent address
S VAPA("P")=""
VDPTTMP ;gets the temporary address if one
S DFN=DVBCDFN
D ADD^VADPT
S VAPA(9999)=$S($D(^DPT(DFN,.13)):$P(^(.13),U,2),1:"")
Q
;
STORTMP ;saves the active temporary address
S DVBTMP(1)=VAPA(1),DVBTMP(2)=VAPA(2),DVBTMP(3)=VAPA(3),DVBTMP(4)=VAPA(4)
S DVBTMP(5)=VAPA(5),DVBTMP(11)=$S($D(VAPA(11)):$P(VAPA(11),"^",2),1:"")
S DVBTMP(7)=VAPA(7),DVBTMP(8)=VAPA(8)
S DVBTMP(9)=VAPA(9),DVBTMP(10)=VAPA(10)
Q
;
MAIL ;to fire a bulletin if necessary
S XMDUZ="AMIE Package",XMSUB="Edit of patient address"
S XMB(1)=DVBCPATN_" SSN: "_DVBCSSN,XMB(2)=DVBCDATE,XMB(3)=$P(^VA(200,DUZ,0),U,1)
S XMB="DVBA C EDIT ADDRESS"
D XMT
S XMTEXT="DVBCML("
D ^XMB
K XMBTEXT,XMTEXT,XMB,XMSUB
W !!,"A bulletin has been sent to the appropriate mail group regarding this",!,"address change!"
Q
;
XMT ;make the text of the bulletin
S DVBCX=1 D LIN
S DVBCML(1)="ADDR.: "_DVBC(1)_DVBCSP_VAPA(1)
S DVBCX=2 D LIN
S DVBCML(2)=" "_DVBC(2)_DVBCSP_VAPA(2)
S DVBCX=3 D LIN
S DVBCML(3)=" "_DVBC(3)_DVBCSP_VAPA(3)
S DVBCX=4 D LIN
S DVBCML(4)="City: "_DVBC(4)_DVBCSP_VAPA(4)
S DVBCX=5 D LIN
S DVBCML(5)="State: "_DVBC(5)_DVBCSP_$P(VAPA(5),U,2)
S DVBCX=11 D LIN
S DVBCML(6)="Zip+4: "_DVBC(11)_DVBCSP_$S($D(VAPA(11)):$P(VAPA(11),"^",2),1:"")
S DVBCX=7 D LIN
S DVBCML(7)="County: "_DVBC(7)_DVBCSP_$P(VAPA(7),U,2)
S DVBCX=8 D LIN
S DVBCML(8)="Phone: "_DVBC(8)_DVBCSP_VAPA(8)
S DVBCX=9999 D LIN
S DVBCML(9)="Office: "_DVBC(9999)_DVBCSP_VAPA(9999)
Q
;
LIN ;makes spaces
K DVBCSP,DVBCSP1
S DVBCSP1=37-$L(DVBC(DVBCX))
S $P(DVBCSP," ",DVBCSP1)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCADR 4224 printed Nov 22, 2024@16:53:35 Page 2
DVBCADR ;ALB/JLU-editing the address ;1/28/93
+1 ;;2.7;AMIE;**19**;Apr 10, 1995
+2 ;
EN ;driver of the program
+1 SET DVBCSTP=0
+2 FOR
Begin DoDot:1
+3 DO PAT
if DVBCSTP
QUIT
+4 DO INIT
if DVBCSTP
QUIT
+5 FOR
DO GUTS
if DVBCSTP1
QUIT
+6 IF DVBCMAL
DO MAIL
End DoDot:1
if DVBCSTP
QUIT
+7 DO EXIT
+8 QUIT
+9 ;
GUTS ;this is the interloop or guts of the driver
+1 DO DISPL
+2 DO ASK
+3 IF 'Y
SET DVBCSTP1=1
QUIT
+4 DO QUES^DGRPU1(DVBCDFN,"ADD1")
+5 IF DGERR
DO ERROR
QUIT
+6 IF DGCHANGE
SET DVBCMAL=1
+7 DO VDPTP
+8 QUIT
+9 ;
EXIT ;cleans variables
+1 KILL %H,DFN,DGCHANGE,DGERR,DIC,DIR,DVBC,DVBCDATE,DVBCDFN,DVBCLINE,DVBCMAL,DVBCPATN,DVBCSSN,DVBCSTP,DVBCSTP1,VAERR,VAPA,Y,XMTEXT,XMY,XMB,XMDUZ,XMSUB,DVBCX,DVBCML,DVBCSP,DVBCSP1,ER,J,C,PNAM,SSN,DVBCSSNO
+2 KILL DVBTMP,XMBTEXT
+3 QUIT
+4 ;
ERROR ;this is an erro printing subroutine
+1 IF DGERR
WRITE !,*7
+2 QUIT
+3 ;
INIT ;initialize variables
+1 IF '$DATA(IOF)
DO HOME^%ZIS
+2 KILL VAPA,DVBTMP,DVBC
+3 SET %H=$HOROLOG
+4 DO YX^%DTC
+5 SET DVBCDATE=$PIECE(Y,"@",1)
+6 SET $PIECE(DVBCLINE,"_",80)=""
+7 SET SSN=$PIECE(^DPT(DVBCDFN,0),U,9)
+8 DO SSNOUT^DVBCUTIL
+9 SET DVBCSSN=DVBCSSNO
+10 DO VDPTTMP
+11 IF VAERR
SET DVBCSTP=1
QUIT
+12 IF +VAPA(9)
Begin DoDot:1
+13 DO STORTMP
+14 KILL VAPA
+15 DO VDPTP
End DoDot:1
+16 IF VAERR
SET DVBCSTP=1
QUIT
+17 DO STORE
+18 SET (DVBCSTP1,DVBCMAL)=0
+19 QUIT
+20 ;
PAT ;get the patient
+1 SET DIC="^DPT("
SET DIC(0)="AEMQ"
+2 DO ^DIC
+3 IF Y<0
SET DVBCSTP=1
QUIT
+4 SET DVBCDFN=+Y
SET (PNAM,DVBCPATN)=$PIECE(Y,U,2)
+5 QUIT
+6 ;
DISPL ;the display subroutine
+1 WRITE @IOF
+2 WRITE "Edit Address Information",?35,$$SITE^DVBCUTL4,?67,DVBCDATE
+3 WRITE !,"Name: ",DVBCPATN,?54,"SSN: ",DVBCSSN
+4 WRITE !,DVBCLINE
+5 WRITE !,?9,"Permanent"
+6 IF $DATA(DVBTMP)
Begin DoDot:1
+7 WRITE ?40,"Temporary: ",$PIECE(DVBTMP(9),U,2)
+8 IF $PIECE(DVBTMP(10),U,2)]""
WRITE " to ",$PIECE(DVBTMP(10),U,2)
End DoDot:1
+9 WRITE !,"Address: ",$EXTRACT(VAPA(1),1,29)
+10 IF $DATA(DVBTMP)
WRITE ?40,$EXTRACT(DVBTMP(1),1,29)
+11 WRITE !,?9,$EXTRACT(VAPA(2),1,29)
+12 IF $DATA(DVBTMP)
WRITE ?40,$EXTRACT(DVBTMP(2),1,29)
+13 WRITE !,?9,$EXTRACT(VAPA(3),1,29)
+14 IF $DATA(DVBTMP)
WRITE ?40,$EXTRACT(DVBTMP(3),1,29)
+15 WRITE !,"City:",?9,VAPA(4)
+16 IF $DATA(DVBTMP)
WRITE ?40,DVBTMP(4)
+17 WRITE !,"State:",?9,$PIECE(VAPA(5),U,2)
+18 IF $DATA(DVBTMP)
WRITE ?40,$PIECE(DVBTMP(5),U,2)
+19 WRITE !,"Zip+4:",?9,$SELECT($DATA(VAPA(11)):$PIECE(VAPA(11),"^",2),1:"")
+20 IF $DATA(DVBTMP)
WRITE ?40,DVBTMP(11)
+21 WRITE !,"County:",?9,$PIECE(VAPA(7),U,2)
+22 IF $DATA(DVBTMP)
WRITE ?40,$PIECE(DVBTMP(7),U,2)
+23 WRITE !,"Phone:",?9,VAPA(8)
+24 IF $DATA(DVBTMP)
WRITE ?40,DVBTMP(8)
+25 WRITE !,"Office:",?9,VAPA(9999)
+26 WRITE !,DVBCLINE
+27 QUIT
+28 ;
ASK ;ask if yes or no
+1 SET DIR(0)="Y"
SET DIR("A")="Do you wish to edit this address:"
SET DIR("B")="YES"
+2 DO ^DIR
+3 QUIT
+4 ;
STORE ;store original address fro possible bulletin
+1 SET DVBC(1)=VAPA(1)
SET DVBC(2)=VAPA(2)
SET DVBC(3)=VAPA(3)
+2 SET DVBC(4)=VAPA(4)
SET DVBC(5)=$PIECE(VAPA(5),U,2)
+3 SET DVBC(11)=$SELECT($DATA(VAPA(11)):$PIECE(VAPA(11),"^",2),1:"")
+4 SET DVBC(7)=$PIECE(VAPA(7),U,2)
SET DVBC(8)=VAPA(8)
+5 SET DVBC(9999)=VAPA(9999)
+6 QUIT
+7 ;
VDPTP ;gets the permanent address
+1 SET VAPA("P")=""
VDPTTMP ;gets the temporary address if one
+1 SET DFN=DVBCDFN
+2 DO ADD^VADPT
+3 SET VAPA(9999)=$SELECT($DATA(^DPT(DFN,.13)):$PIECE(^(.13),U,2),1:"")
+4 QUIT
+5 ;
STORTMP ;saves the active temporary address
+1 SET DVBTMP(1)=VAPA(1)
SET DVBTMP(2)=VAPA(2)
SET DVBTMP(3)=VAPA(3)
SET DVBTMP(4)=VAPA(4)
+2 SET DVBTMP(5)=VAPA(5)
SET DVBTMP(11)=$SELECT($DATA(VAPA(11)):$PIECE(VAPA(11),"^",2),1:"")
+3 SET DVBTMP(7)=VAPA(7)
SET DVBTMP(8)=VAPA(8)
+4 SET DVBTMP(9)=VAPA(9)
SET DVBTMP(10)=VAPA(10)
+5 QUIT
+6 ;
MAIL ;to fire a bulletin if necessary
+1 SET XMDUZ="AMIE Package"
SET XMSUB="Edit of patient address"
+2 SET XMB(1)=DVBCPATN_" SSN: "_DVBCSSN
SET XMB(2)=DVBCDATE
SET XMB(3)=$PIECE(^VA(200,DUZ,0),U,1)
+3 SET XMB="DVBA C EDIT ADDRESS"
+4 DO XMT
+5 SET XMTEXT="DVBCML("
+6 DO ^XMB
+7 KILL XMBTEXT,XMTEXT,XMB,XMSUB
+8 WRITE !!,"A bulletin has been sent to the appropriate mail group regarding this",!,"address change!"
+9 QUIT
+10 ;
XMT ;make the text of the bulletin
+1 SET DVBCX=1
DO LIN
+2 SET DVBCML(1)="ADDR.: "_DVBC(1)_DVBCSP_VAPA(1)
+3 SET DVBCX=2
DO LIN
+4 SET DVBCML(2)=" "_DVBC(2)_DVBCSP_VAPA(2)
+5 SET DVBCX=3
DO LIN
+6 SET DVBCML(3)=" "_DVBC(3)_DVBCSP_VAPA(3)
+7 SET DVBCX=4
DO LIN
+8 SET DVBCML(4)="City: "_DVBC(4)_DVBCSP_VAPA(4)
+9 SET DVBCX=5
DO LIN
+10 SET DVBCML(5)="State: "_DVBC(5)_DVBCSP_$PIECE(VAPA(5),U,2)
+11 SET DVBCX=11
DO LIN
+12 SET DVBCML(6)="Zip+4: "_DVBC(11)_DVBCSP_$SELECT($DATA(VAPA(11)):$PIECE(VAPA(11),"^",2),1:"")
+13 SET DVBCX=7
DO LIN
+14 SET DVBCML(7)="County: "_DVBC(7)_DVBCSP_$PIECE(VAPA(7),U,2)
+15 SET DVBCX=8
DO LIN
+16 SET DVBCML(8)="Phone: "_DVBC(8)_DVBCSP_VAPA(8)
+17 SET DVBCX=9999
DO LIN
+18 SET DVBCML(9)="Office: "_DVBC(9999)_DVBCSP_VAPA(9999)
+19 QUIT
+20 ;
LIN ;makes spaces
+1 KILL DVBCSP,DVBCSP1
+2 SET DVBCSP1=37-$LENGTH(DVBC(DVBCX))
+3 SET $PIECE(DVBCSP," ",DVBCSP1)=""
+4 QUIT
