RMPOLF1 ;HIN CIOFO-DRIVER FOR HO LETTERS ;7/8/98
;;3.0;PROSTHETICS;**29**;Feb 09, 1996
NAME ;
S RMPRNAME=$P(RMPRNAME," ",1,2) K RMPRVIEW,RMPRPRIN
I $P(VADM(5),U)["M" S ^TMP($J,"DW",19,0)="|TAB|"_"Dear Mr. "_RMPRNAME_":"
E S ^TMP($J,"DW",19,0)="|TAB|"_"Dear Ms. "_RMPRNAME_":"
S RV=21 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,"DW",RV,0)=TAB_^(0),RV=RV+1
I $G(RMPRTFLG) G SETALL^RMPOLF2
EDIT S DIC="^TMP($J,""DW""," D EN^DIWE S RMPRFLAG=1
EDIT1 S %=1 W !,"Do you wish to view this letter" D YN^DICN
I %<0 G END
I %=0 W !,"Answer `YES` to view the letter, `NO` to not" G EDIT1
I %=1 G:$G(RMPRPRIN)'="" PRINT S RMPRPRIN=1,RMPRVIEW=1 G SET^RMPOLF2
ASK ;
S %=1 W !,"Do you wish to accept this letter" D YN^DICN
I %<0 G END
I %=0 W !,"Answer `YES` or `NO`" G ASK
I %=2 G ASK2
K RMPRVIEW G:$D(RMPRPRIN) PRINT G SET^RMPOLF2
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
I %=1!(%<0) D Q
.I $G(RMPRIN)'>0 W $C(7),!!,?35,"Letter Deleted..." D END Q
.I $D(^RMPR(665.4,RMPRIN,0)) D DEL^RMPOLF1
.W $C(7),!!,?35,"Deleted..." H 1 Q
I %=0 W !,"Enter `YES` to Delete this letter" G ASK2
G EDIT
;
PRALL ;print all letter
S DIC="^RMPR(665.4,",RMPRPG=0,DHD="[RMPR BLANK]-[RMPR PAGE]"
S ZTSAVE("^TMP(""RL"",$J,")=""
S DIS(0)="I $D(^TMP(""RL"",$J,1,D0))"
S BY="@NUMBER",(TO,FR)="",FLDS="3",L=0,PG=2,DHIT="W @IOF"
D EN1^DIP
Q
;
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)
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
;next line is needed, if not a HOME device.
D EN1^DIP I '$D(POP) S POP=0
I POP S RMPRGO=$S($D(^RMPR(665.4,RMPRIN,0)):"DEL^RMPOLF1",1:"END^RMPOLF1") D @RMPRGO W ?9," Deleted..." S RMQUIT=1 Q
G:$G(RMPRVIEW) ASK ;if only a view, go back and ask user to ACCEPT.
EXIT ;common exit point
;unlock letter and sets printed date and flag for the patient entry.
L:$D(RMPRIN) -^RMPR(665.4,RMPRIN,0)
S RMC=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"") Q:RMC=""
S DA(1)=RMPOXITE,DIK="^RMPR(669.9,"_RMPOXITE_","_""""_RMC_""""_","
S DA=RMDA D ^DIK S RMPRNT=1
S RMPI=$S(RMPOLCD="A":9,RMPOLCD="B":11,RMPOLCD="C":13,1:"")
I RMPI S $P(^RMPR(665,DFN,"RMPOA"),U,RMPI)=DT,$P(^RMPR(665,DFN,"RMPOA"),U,RMPI+1)="P"
K ^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)
K ^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)
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
K DIK,RMC,DA D ^%ZISC
Q
DEL I $D(RMPRDELE) S %=2 W !,"Are you sure you want to delete this letter" D YN^DICN I %=0 W !,"Answer `YES` to Delete the letter, `NO` to exit" G DEL
I $D(RMPRDELE),(%<0!(%=2)) G EXIT
S DIK="^RMPR(665.4,",DA=RMPRIN D ^DIK G EXIT
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLF1 3323 printed Oct 16, 2024@18:31:41 Page 2
RMPOLF1 ;HIN CIOFO-DRIVER FOR HO LETTERS ;7/8/98
+1 ;;3.0;PROSTHETICS;**29**;Feb 09, 1996
NAME ;
+1 SET RMPRNAME=$PIECE(RMPRNAME," ",1,2)
KILL RMPRVIEW,RMPRPRIN
+2 IF $PIECE(VADM(5),U)["M"
SET ^TMP($JOB,"DW",19,0)="|TAB|"_"Dear Mr. "_RMPRNAME_":"
+3 IF '$TEST
SET ^TMP($JOB,"DW",19,0)="|TAB|"_"Dear Ms. "_RMPRNAME_":"
+4 SET RV=21
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,"DW",RV,0)=TAB_^(0)
SET RV=RV+1
+6 IF $GET(RMPRTFLG)
GOTO SETALL^RMPOLF2
EDIT SET DIC="^TMP($J,""DW"","
DO EN^DIWE
SET RMPRFLAG=1
EDIT1 SET %=1
WRITE !,"Do you wish to view this letter"
DO YN^DICN
+1 IF %<0
GOTO END
+2 IF %=0
WRITE !,"Answer `YES` to view the letter, `NO` to not"
GOTO EDIT1
+3 IF %=1
if $GET(RMPRPRIN)'=""
GOTO PRINT
SET RMPRPRIN=1
SET RMPRVIEW=1
GOTO SET^RMPOLF2
ASK ;
+1 SET %=1
WRITE !,"Do you wish to accept this letter"
DO YN^DICN
+2 IF %<0
GOTO END
+3 IF %=0
WRITE !,"Answer `YES` or `NO`"
GOTO ASK
+4 IF %=2
GOTO ASK2
+5 KILL RMPRVIEW
if $DATA(RMPRPRIN)
GOTO PRINT
GOTO SET^RMPOLF2
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 IF %=1!(%<0)
Begin DoDot:1
+4 IF $GET(RMPRIN)'>0
WRITE $CHAR(7),!!,?35,"Letter Deleted..."
DO END
QUIT
+5 IF $DATA(^RMPR(665.4,RMPRIN,0))
DO DEL^RMPOLF1
+6 WRITE $CHAR(7),!!,?35,"Deleted..."
HANG 1
QUIT
End DoDot:1
QUIT
+7 IF %=0
WRITE !,"Enter `YES` to Delete this letter"
GOTO ASK2
+8 GOTO EDIT
+9 ;
PRALL ;print all letter
+1 SET DIC="^RMPR(665.4,"
SET RMPRPG=0
SET DHD="[RMPR BLANK]-[RMPR PAGE]"
+2 SET ZTSAVE("^TMP(""RL"",$J,")=""
+3 SET DIS(0)="I $D(^TMP(""RL"",$J,1,D0))"
+4 SET BY="@NUMBER"
SET (TO,FR)=""
SET FLDS="3"
SET L=0
SET PG=2
SET DHIT="W @IOF"
+5 DO EN1^DIP
+6 QUIT
+7 ;
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 SET DIC="^RMPR(665.4,"
SET RMPRPG=0
SET DHD="[RMPR BLANK]-[RMPR PAGE]"
+6 SET BY="@NUMBER"
SET FR=RMPRIN
SET TO=RMPRIN
SET FLDS="3"
SET L=0
SET PG=2
+7 ;next line is needed, if not a HOME device.
+8 DO EN1^DIP
IF '$DATA(POP)
SET POP=0
+9 IF POP
SET RMPRGO=$SELECT($DATA(^RMPR(665.4,RMPRIN,0)):"DEL^RMPOLF1",1:"END^RMPOLF1")
DO @RMPRGO
WRITE ?9," Deleted..."
SET RMQUIT=1
QUIT
+10 ;if only a view, go back and ask user to ACCEPT.
if $GET(RMPRVIEW)
GOTO ASK
EXIT ;common exit point
+1 ;unlock letter and sets printed date and flag for the patient entry.
+2 if $DATA(RMPRIN)
LOCK -^RMPR(665.4,RMPRIN,0)
+3 SET RMC=$SELECT(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
if RMC=""
QUIT
+4 SET DA(1)=RMPOXITE
SET DIK="^RMPR(669.9,"_RMPOXITE_","_""""_RMC_""""_","
+5 SET DA=RMDA
DO ^DIK
SET RMPRNT=1
+6 SET RMPI=$SELECT(RMPOLCD="A":9,RMPOLCD="B":11,RMPOLCD="C":13,1:"")
+7 IF RMPI
SET $PIECE(^RMPR(665,DFN,"RMPOA"),U,RMPI)=DT
SET $PIECE(^RMPR(665,DFN,"RMPOA"),U,RMPI+1)="P"
+8 KILL ^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)
+9 KILL ^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM)
+10 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
+11 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
+12 KILL DIK,RMC,DA
DO ^%ZISC
+13 QUIT
DEL IF $DATA(RMPRDELE)
SET %=2
WRITE !,"Are you sure you want to delete this letter"
DO YN^DICN
IF %=0
WRITE !,"Answer `YES` to Delete the letter, `NO` to exit"
GOTO DEL
+1 IF $DATA(RMPRDELE)
IF (%<0!(%=2))
GOTO EXIT
+2 SET DIK="^RMPR(665.4,"
SET DA=RMPRIN
DO ^DIK
GOTO EXIT
END QUIT
