- 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 Mar 13, 2025@21:39:37 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
