- RMPRUTL2 ;PHX/HPL-Patient Letter Date look-up in chronological order ;05/22/1995
- ;;3.0;PROSTHETICS;;Feb 09, 1996
- EN1 ;entry point to ask patient
- I '$D(RMPR) D DIV4^RMPRSIT
- D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
- EN ;entry point pass RMPRDFN
- ;return RMPRPRIN as ien of 665.4 if a selection is made, otherwise
- ;RMPRIN is PASSED BACK AS -1.
- I $G(RMPRDFN)'>0 S:$G(DFN)>0 RMPRDFN=DFN D:$G(DFN)'>0 EN1^RMPRUTL2
- I '$D(^RMPR(665.4,"AH",RMPRDFN)) W !!,$C(7),?5,"NO LETTERS FOR THIS PATIENT!" S RMPRIN=-1 Q
- N RMPRBDT,DIC,RI,DR,RB,DA,RMPLET,DIQ,Y,RO
- S (RMPRBDT,RI,RB,RO)=0,RMPRIN=-1,DIC=665.4,DR=".01;1;2;4;11",DIQ="RMPRLET"
- W !!,"#",?5,"Patient",?28,"Type of letter",?45,"Employee"
- W ?65,"Date of letter"
- W !,RMPR("L")
- F S RMPRBDT=$O(^RMPR(665.4,"AH",RMPRDFN,RMPRBDT)) Q:RMPRBDT="" D Q:RO=1
- .;check for more than one letter per day
- .S DA=0
- .F S DA=$O(^RMPR(665.4,"AH",RMPRDFN,RMPRBDT,DA)) Q:'DA D Q:RO=1
- ..S RI=RI+1,RI(RI)=DA D EN^DIQ1 Q:'$D(RMPRLET)
- ..S RB=RB+1
- ..W !,RI
- ..W ?5,RMPRLET(665.4,DA,.01),?28,$G(RMPRLET(665.4,DA,1))
- ..W ?45,$E($G(RMPRLET(665.4,DA,4)),1,15)
- ..W ?65,$G(RMPRLET(665.4,DA,2))_$G(RMPRLET(665.4,DA,11))
- ..K RMPRLET
- ..I RB>4&(RMPRIN<1) D ASK Q:RMPRIN>0 S RB=0
- G:$D(DTOUT)!($D(DUOUT)) EXIT
- I RMPRIN'>0 S:'RI(RI) RI=RI-1 D ASK Q
- G EXIT
- Q
- ASK ;get record
- I RMPRBDT="",DA="" W !!,"End of Patient's Letter Listing."
- W !!,"Enter '^' to stop or "
- N DIR S DIR(0)="NO^1:"_RI_":0" D ^DIR
- I ($D(DTOUT))!($D(DUOUT)) S RO=1 Q
- I +Y>0 S RMPRIN=RI(Y),RO=1 Q
- Q
- EXIT ;common exit point
- K DTOUT,DUOUT,RMPRBDT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRUTL2 1582 printed Mar 13, 2025@21:42:55 Page 2
- RMPRUTL2 ;PHX/HPL-Patient Letter Date look-up in chronological order ;05/22/1995
- +1 ;;3.0;PROSTHETICS;;Feb 09, 1996
- EN1 ;entry point to ask patient
- +1 IF '$DATA(RMPR)
- DO DIV4^RMPRSIT
- +2 DO GETPAT^RMPRUTIL
- if '$DATA(RMPRDFN)
- QUIT
- EN ;entry point pass RMPRDFN
- +1 ;return RMPRPRIN as ien of 665.4 if a selection is made, otherwise
- +2 ;RMPRIN is PASSED BACK AS -1.
- +3 IF $GET(RMPRDFN)'>0
- if $GET(DFN)>0
- SET RMPRDFN=DFN
- if $GET(DFN)'>0
- DO EN1^RMPRUTL2
- +4 IF '$DATA(^RMPR(665.4,"AH",RMPRDFN))
- WRITE !!,$CHAR(7),?5,"NO LETTERS FOR THIS PATIENT!"
- SET RMPRIN=-1
- QUIT
- +5 NEW RMPRBDT,DIC,RI,DR,RB,DA,RMPLET,DIQ,Y,RO
- +6 SET (RMPRBDT,RI,RB,RO)=0
- SET RMPRIN=-1
- SET DIC=665.4
- SET DR=".01;1;2;4;11"
- SET DIQ="RMPRLET"
- +7 WRITE !!,"#",?5,"Patient",?28,"Type of letter",?45,"Employee"
- +8 WRITE ?65,"Date of letter"
- +9 WRITE !,RMPR("L")
- +10 FOR
- SET RMPRBDT=$ORDER(^RMPR(665.4,"AH",RMPRDFN,RMPRBDT))
- if RMPRBDT=""
- QUIT
- Begin DoDot:1
- +11 ;check for more than one letter per day
- +12 SET DA=0
- +13 FOR
- SET DA=$ORDER(^RMPR(665.4,"AH",RMPRDFN,RMPRBDT,DA))
- if 'DA
- QUIT
- Begin DoDot:2
- +14 SET RI=RI+1
- SET RI(RI)=DA
- DO EN^DIQ1
- if '$DATA(RMPRLET)
- QUIT
- +15 SET RB=RB+1
- +16 WRITE !,RI
- +17 WRITE ?5,RMPRLET(665.4,DA,.01),?28,$GET(RMPRLET(665.4,DA,1))
- +18 WRITE ?45,$EXTRACT($GET(RMPRLET(665.4,DA,4)),1,15)
- +19 WRITE ?65,$GET(RMPRLET(665.4,DA,2))_$GET(RMPRLET(665.4,DA,11))
- +20 KILL RMPRLET
- +21 IF RB>4&(RMPRIN<1)
- DO ASK
- if RMPRIN>0
- QUIT
- SET RB=0
- End DoDot:2
- if RO=1
- QUIT
- End DoDot:1
- if RO=1
- QUIT
- +22 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT
- +23 IF RMPRIN'>0
- if 'RI(RI)
- SET RI=RI-1
- DO ASK
- QUIT
- +24 GOTO EXIT
- +25 QUIT
- ASK ;get record
- +1 IF RMPRBDT=""
- IF DA=""
- WRITE !!,"End of Patient's Letter Listing."
- +2 WRITE !!,"Enter '^' to stop or "
- +3 NEW DIR
- SET DIR(0)="NO^1:"_RI_":0"
- DO ^DIR
- +4 IF ($DATA(DTOUT))!($DATA(DUOUT))
- SET RO=1
- QUIT
- +5 IF +Y>0
- SET RMPRIN=RI(Y)
- SET RO=1
- QUIT
- +6 QUIT
- EXIT ;common exit point
- +1 KILL DTOUT,DUOUT,RMPRBDT
- +2 QUIT
