- 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 Feb 18, 2025@23:57:30 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