RMPRFO1 ;PHX/RFM,HPL-DRIVER FOR PROSTHETIC LETTERS ;3/17/03 12:19
;;3.0;PROSTHETICS;**8,44,77,105**;Feb 09, 1996
;RVD 3/17/03 patch #77 - remove link to suspense from letter module.
NAME ;
S RMPRNAME=$P(RMPRNAME," ",1,2)
I $P(VADM(5),U)["M" S ^TMP($J,1,16,0)="|TAB|"_"Dear Mr. "_RMPRNAME_":"
E S ^TMP($J,1,16,0)="|TAB|"_"Dear Ms. "_RMPRNAME_":"
S RV=18 F RI=0:0 S RI=$O(^RMPR(665.2,RMPRFA,1,RI)) Q:RI'>0 Q:^(RI,0)'=" "
S RI=RI-1 F S RI=$O(^RMPR(665.2,RMPRFA,1,RI)) Q:RI'>0 S TAB=$S($P(^RMPR(665.2,RMPRFA,1,RI,0),U)["|TAB|":"",1:"|TAB|") S ^TMP($J,1,RV,0)=TAB_^(0),RV=RV+1
EDIT S DIC="^TMP($J,1," D EN^DIWE S RMPRFLAG=1
EDIT1 S %=1 W !,"Do you wish to view this letter" D YN^DICN
S RMPRAA68=% I RMPRAA68<0 G EXIT^RMPRFO1
I RMPRAA68=0 W !,"Answer `YES` to view the letter, `NO` to not" G EDIT1
I RMPRAA68=1 S RMPRFFL=1 G:$G(RMPRPRIN)'="" PRINT S RMPRPRIN=1 G SET^RMPRFO2
ASK ;
S %=1 W !,"Do you wish to accept this letter" D YN^DICN
S RMPRAA68=% I RMPRAA68<0 G EXIT^RMPRFO1
I RMPRAA68=0 W !,"Answer `YES` or `NO`" G ASK
I RMPRAA68=2 G ASK2
K RMPRFFL G:$D(RMPRPRIN) PRINT G SET^RMPRFO2
ASK2 ;DECIDES TO KEEP EDITING LETTER OR DELETE IT
; ALREADY SAID NOT TO ACCEPT LETTER
S %=2 W !,"Do you wish to Delete this letter" D YN^DICN
S RMPRAA68=% I RMPRAA68=1!(RMPRAA68<0) D Q
.I $G(RMPRIN)'>0 W $C(7),!!,?35,"Letter Deleted..." D EXIT^RMPRFO1 Q
.I $D(^RMPR(665.4,RMPRIN,0)) D DEL^RMPRFO1
.W $C(7),!!,?35,"Deleted..." H 1 Q
I RMPRAA68=0 W !,"Enter `YES` to Delete this letter" G ASK2
G EDIT
EN2 ;PRINT/DELETE A LETTER
K DIC D DIV4^RMPRSIT I $D(Y),(Y<0) G EXIT
D HOME^%ZIS S DIC=2,DIC(0)="AEQMZ",DIC("A")="Select PATIENT: "
DICW ;CHOOSE THE LETTER TO PRINT
;S DIC("W")="S (RMPRDFN,DFN)=+Y" D ^DIC K DIC G:Y<0 EXIT
D ^DIC K DIC G:Y<0 EXIT S (RMPRDFN,DFN)=+Y
D EN^RMPRUTL2 Q:RMPRIN=-1 S:$G(RMPRIN)>0 DA=RMPRIN
Q:$G(DA)<1 Q:$G(DA)="" S RMPRIN=DA
Q:$G(RMPRIN)'>0 S RMPRTY=$P(^RMPR(665.4,RMPRIN,0),U,2) L +^RMPR(665.4,RMPRIN,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
G:$D(RMPRDELE) DEL
S DA=RMPRIN,ITMFLG=0 S:$D(^RMPR(665.4,DA,3,0)) ITMFLG=$P(^RMPR(665.4,DA,3,0),U,4) S:ITMFLG>4 ITMFLG=1
S ITM=RMPRIN
I $P(^RMPR(665.2,RMPRTY,0),U,3) D PRNT1^RMPRFO3 K RMPRTY,DA,ITM,ITMFLG D EXIT^RMPRFO3 G EXIT
PRINT ;VIEW LETTER
I $G(RMPRIN)'>0 Q:$G(RMPRDA)'>0 S RMPRIN=RMPRDA
S DFN=$P(^RMPR(665.4,RMPRIN,0),U)
S RMPRTY=$P(^RMPR(665.4,RMPRIN,0),U,2)
S RMPR1=^RMPR(665.2,RMPRTY,0)
I $P(^RMPR(665.2,RMPRTY,0),U,3) S DA=RMPRIN K RMPR1 G PRNT1^RMPRFO3
S DIC="^RMPR(665.4,",RMPRPG=0,DHD="[RMPR BLANK]-[RMPR PAGE]"
S BY="@NUMBER",FR=RMPRIN,TO=RMPRIN,FLDS="3",L=0,PG=2
D EN1^DIP I '$D(POP) S POP=0
I POP,$D(RMPRFFL) S RMPRGO=$S($D(^RMPR(665.4,RMPRIN,0)):"DEL^RMPRFO1",1:"EXIT^RMPRFO1") D @RMPRGO W ?9," Deleted..." G EXIT
;I '$D(RMPRFFL),'$D(RNSK) S RMPRDFN=DFN D LINK^RMPRS G EXIT
;I 'POP,'$D(RMPRFFL),'$D(RNSK) S RMPRDFN=DFN K DIR S DIR(0)="E" W ! D ^DIR,LINK^RMPRS G EXIT
VI I $D(RMPRFFL) R !!,"Enter `return` to continue: ",X:DTIME G:'$T EXIT I X'="" W $C(7),!,"You may only enter `return` here.." G VI
I $D(RMPRFFL) S DIE="^RMPR(665.4,",DA=RMPRIN,DR=3,DIE("NO^")="" D ^DIE G:$D(DTOUT)!($D(DUOUT)) EXIT G EDIT1
EXIT ;common exit point
L:$D(RMPRIN) -^RMPR(665.4,RMPRIN,0)
K ^TMP($J,1),^TMP($J,"RMPR")
K %X,RMPRFFL,RMPRHED,RMPRPRIN,%Y,RMPRDEL,RMPRRVA,DIC,RMPRFA,KILL,DIE,DA,DR,DIK,RMPR1,RMPR2,RMPRDATE,RMPRIN,RMPRL,RMPRNAME,RMPRU,RMPRDELE,FR,RI,RV
I '$D(RMPRCOMB)!('$D(RMPRFF)) K RMPREND,VADM,VAPA,VA,NAME,RMPRGO,NAME1,RMPRDEN,RMPRFLAG,RMPRNAM1,RMPRNAM2,RMPRFF,J,RP,RO,RZ D KVAR^VADPT
D ^%ZISC Q
DEL I $D(RMPRDELE) S %=2 W !,"Are you sure you want to delete this letter" D YN^DICN S RMPRAA68=% I RMPRAA68=0 W !,"Answer `YES` to Delete the letter, `NO` to exit" G DEL
I $D(RMPRDELE),(RMPRAA68<0!(RMPRAA68=2)) G EXIT
S DIK="^RMPR(665.4,",DA=RMPRIN D ^DIK G EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRFO1 3882 printed Oct 16, 2024@18:35:22 Page 2
RMPRFO1 ;PHX/RFM,HPL-DRIVER FOR PROSTHETIC LETTERS ;3/17/03 12:19
+1 ;;3.0;PROSTHETICS;**8,44,77,105**;Feb 09, 1996
+2 ;RVD 3/17/03 patch #77 - remove link to suspense from letter module.
NAME ;
+1 SET RMPRNAME=$PIECE(RMPRNAME," ",1,2)
+2 IF $PIECE(VADM(5),U)["M"
SET ^TMP($JOB,1,16,0)="|TAB|"_"Dear Mr. "_RMPRNAME_":"
+3 IF '$TEST
SET ^TMP($JOB,1,16,0)="|TAB|"_"Dear Ms. "_RMPRNAME_":"
+4 SET RV=18
FOR RI=0:0
SET RI=$ORDER(^RMPR(665.2,RMPRFA,1,RI))
if RI'>0
QUIT
if ^(RI,0)'=" "
QUIT
+5 SET RI=RI-1
FOR
SET RI=$ORDER(^RMPR(665.2,RMPRFA,1,RI))
if RI'>0
QUIT
SET TAB=$SELECT($PIECE(^RMPR(665.2,RMPRFA,1,RI,0),U)["|TAB|":"",1:"|TAB|")
SET ^TMP($JOB,1,RV,0)=TAB_^(0)
SET RV=RV+1
EDIT SET DIC="^TMP($J,1,"
DO EN^DIWE
SET RMPRFLAG=1
EDIT1 SET %=1
WRITE !,"Do you wish to view this letter"
DO YN^DICN
+1 SET RMPRAA68=%
IF RMPRAA68<0
GOTO EXIT^RMPRFO1
+2 IF RMPRAA68=0
WRITE !,"Answer `YES` to view the letter, `NO` to not"
GOTO EDIT1
+3 IF RMPRAA68=1
SET RMPRFFL=1
if $GET(RMPRPRIN)'=""
GOTO PRINT
SET RMPRPRIN=1
GOTO SET^RMPRFO2
ASK ;
+1 SET %=1
WRITE !,"Do you wish to accept this letter"
DO YN^DICN
+2 SET RMPRAA68=%
IF RMPRAA68<0
GOTO EXIT^RMPRFO1
+3 IF RMPRAA68=0
WRITE !,"Answer `YES` or `NO`"
GOTO ASK
+4 IF RMPRAA68=2
GOTO ASK2
+5 KILL RMPRFFL
if $DATA(RMPRPRIN)
GOTO PRINT
GOTO SET^RMPRFO2
ASK2 ;DECIDES TO KEEP EDITING LETTER OR DELETE IT
+1 ; ALREADY SAID NOT TO ACCEPT LETTER
+2 SET %=2
WRITE !,"Do you wish to Delete this letter"
DO YN^DICN
+3 SET RMPRAA68=%
IF RMPRAA68=1!(RMPRAA68<0)
Begin DoDot:1
+4 IF $GET(RMPRIN)'>0
WRITE $CHAR(7),!!,?35,"Letter Deleted..."
DO EXIT^RMPRFO1
QUIT
+5 IF $DATA(^RMPR(665.4,RMPRIN,0))
DO DEL^RMPRFO1
+6 WRITE $CHAR(7),!!,?35,"Deleted..."
HANG 1
QUIT
End DoDot:1
QUIT
+7 IF RMPRAA68=0
WRITE !,"Enter `YES` to Delete this letter"
GOTO ASK2
+8 GOTO EDIT
EN2 ;PRINT/DELETE A LETTER
+1 KILL DIC
DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
GOTO EXIT
+2 DO HOME^%ZIS
SET DIC=2
SET DIC(0)="AEQMZ"
SET DIC("A")="Select PATIENT: "
DICW ;CHOOSE THE LETTER TO PRINT
+1 ;S DIC("W")="S (RMPRDFN,DFN)=+Y" D ^DIC K DIC G:Y<0 EXIT
+2 DO ^DIC
KILL DIC
if Y<0
GOTO EXIT
SET (RMPRDFN,DFN)=+Y
+3 DO EN^RMPRUTL2
if RMPRIN=-1
QUIT
if $GET(RMPRIN)>0
SET DA=RMPRIN
+4 if $GET(DA)<1
QUIT
if $GET(DA)=""
QUIT
SET RMPRIN=DA
+5 if $GET(RMPRIN)'>0
QUIT
SET RMPRTY=$PIECE(^RMPR(665.4,RMPRIN,0),U,2)
LOCK +^RMPR(665.4,RMPRIN,0):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
GOTO EXIT
+6 if $DATA(RMPRDELE)
GOTO DEL
+7 SET DA=RMPRIN
SET ITMFLG=0
if $DATA(^RMPR(665.4,DA,3,0))
SET ITMFLG=$PIECE(^RMPR(665.4,DA,3,0),U,4)
if ITMFLG>4
SET ITMFLG=1
+8 SET ITM=RMPRIN
+9 IF $PIECE(^RMPR(665.2,RMPRTY,0),U,3)
DO PRNT1^RMPRFO3
KILL RMPRTY,DA,ITM,ITMFLG
DO EXIT^RMPRFO3
GOTO EXIT
PRINT ;VIEW LETTER
+1 IF $GET(RMPRIN)'>0
if $GET(RMPRDA)'>0
QUIT
SET RMPRIN=RMPRDA
+2 SET DFN=$PIECE(^RMPR(665.4,RMPRIN,0),U)
+3 SET RMPRTY=$PIECE(^RMPR(665.4,RMPRIN,0),U,2)
+4 SET RMPR1=^RMPR(665.2,RMPRTY,0)
+5 IF $PIECE(^RMPR(665.2,RMPRTY,0),U,3)
SET DA=RMPRIN
KILL RMPR1
GOTO PRNT1^RMPRFO3
+6 SET DIC="^RMPR(665.4,"
SET RMPRPG=0
SET DHD="[RMPR BLANK]-[RMPR PAGE]"
+7 SET BY="@NUMBER"
SET FR=RMPRIN
SET TO=RMPRIN
SET FLDS="3"
SET L=0
SET PG=2
+8 DO EN1^DIP
IF '$DATA(POP)
SET POP=0
+9 IF POP
IF $DATA(RMPRFFL)
SET RMPRGO=$SELECT($DATA(^RMPR(665.4,RMPRIN,0)):"DEL^RMPRFO1",1:"EXIT^RMPRFO1")
DO @RMPRGO
WRITE ?9," Deleted..."
GOTO EXIT
+10 ;I '$D(RMPRFFL),'$D(RNSK) S RMPRDFN=DFN D LINK^RMPRS G EXIT
+11 ;I 'POP,'$D(RMPRFFL),'$D(RNSK) S RMPRDFN=DFN K DIR S DIR(0)="E" W ! D ^DIR,LINK^RMPRS G EXIT
VI IF $DATA(RMPRFFL)
READ !!,"Enter `return` to continue: ",X:DTIME
if '$TEST
GOTO EXIT
IF X'=""
WRITE $CHAR(7),!,"You may only enter `return` here.."
GOTO VI
+1 IF $DATA(RMPRFFL)
SET DIE="^RMPR(665.4,"
SET DA=RMPRIN
SET DR=3
SET DIE("NO^")=""
DO ^DIE
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
GOTO EDIT1
EXIT ;common exit point
+1 if $DATA(RMPRIN)
LOCK -^RMPR(665.4,RMPRIN,0)
+2 KILL ^TMP($JOB,1),^TMP($JOB,"RMPR")
+3 KILL %X,RMPRFFL,RMPRHED,RMPRPRIN,%Y,RMPRDEL,RMPRRVA,DIC,RMPRFA,KILL,DIE,DA,DR,DIK,RMPR1,RMPR2,RMPRDATE,RMPRIN,RMPRL,RMPRNAME,RMPRU,RMPRDELE,FR,RI,RV
+4 IF '$DATA(RMPRCOMB)!('$DATA(RMPRFF))
KILL RMPREND,VADM,VAPA,VA,NAME,RMPRGO,NAME1,RMPRDEN,RMPRFLAG,RMPRNAM1,RMPRNAM2,RMPRFF,J,RP,RO,RZ
DO KVAR^VADPT
+5 DO ^%ZISC
QUIT
DEL IF $DATA(RMPRDELE)
SET %=2
WRITE !,"Are you sure you want to delete this letter"
DO YN^DICN
SET RMPRAA68=%
IF RMPRAA68=0
WRITE !,"Answer `YES` to Delete the letter, `NO` to exit"
GOTO DEL
+1 IF $DATA(RMPRDELE)
IF (RMPRAA68<0!(RMPRAA68=2))
GOTO EXIT
+2 SET DIK="^RMPR(665.4,"
SET DA=RMPRIN
DO ^DIK
GOTO EXIT
