RMPRUTIL ;PHX/JLT,DLG,HPL,RVD-UTILITY PROGRAMS FOR PROSTHETICS ;10/19/1993
;;3.0;PROSTHETICS;**12,28,30,44,41,55**;Feb 09, 1996
;
; ODJ - patch 55 - 1/29/01 - create extrinsic to return mail routing
; code parameter. (see AUG-1097-32118)
; RVD - patch 55 - 3/15/01 - initially set the value of 121 as the
; mail routing symbol @ the post init.
;
GETPAT ;MAIN ENTRY POINT FOR PATIENT LOOKUPS
K RMPRDFN,RMPRSSN,RMPRSSNE,RMPRDOB
N DIC,Y,DLAYGO,VAHOW S DIC="^RMPR(665,",DIC(0)="AEMLQ",DLAYGO=665,DIC("A")="Select PROSTHETIC PATIENT: " D ^DIC K DIC,DLAYGO
Q:$G(Y)'>0
S:+Y>0 (RMPRDFN,DFN)=+Y D DEM^VADPT,ELIG^VADPT
;set prosthetic variables
;rmprssn is number nnnnnnnnn
;rmprssne is external format of ssn nnn-nn-nnnn
S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
S RMPRCNUM=VAEL(7)
I +VADM(6) S RMPRDOD=$P(VADM(6),U) W !!,$C(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$P(VADM(6),U,2)
I $D(RMPRDOD) S DIR(0)="Y",DIR("A")="Would you Like to continue Processing this Patient",DIR("B")="NO" D ^DIR K DIR I +Y=0 K RMPRDFN
K RMPRDOD D KVAR^VADPT Q
COMP ;LOOKUP FOR ADDRESS ON PATIENT 10-2319
S DFN=RMPRDFN,VAPA("P")="" D ADD^VADPT
S J=1 F I=1:1:3 S:VAPA(I)'="" XP(J)=VAPA(I),J=J+1
S XP(J)=$P(VAPA(4),U)_", "_$P(VAPA(5),U,2)_" "_$P(VAPA(6),U,1)
S:XP(J)=", " XP(J)="" S:XP(J)]"" J=J+1 S:XP(1)="" XP(J)="NO ADDRESS ON FILE",J=2
K VAPA S DFN=RMPRDFN D ADD^VADPT
S J1=1 F I=1:1:3 S:VAPA(I)'="" X1(J1)=VAPA(I),J1=J1+1
S X1(J1)=$P(VAPA(4),U)_", "_$P(VAPA(5),U,2)_" "_$P(VAPA(6),U)
S:X1(J1)=", " X1(J1)="" S:X1(1)="" X1(J1)="NO ADDRESS ON FILE" S J1=J1+1 Q
EDT ;ENTER/EDIT 2421 AND NO-FORM
S HY=+Y I '$D(^RMPR(664,RMPRA,1)) S ^RMPR(664,RMPRA,1,0)="^664.02PA^0^0" G FILE
I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK
FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1
ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," S DR=$S($D(NEW):"",1:".01;") K NEW I RMPRDR'["2421" G NFRM
S DR=DR_"16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
S DR=DR_"14;3;2;4R;11////C;7REMARKS (2319 and 1358)"
;S DR=DR_"16;8;9;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
;S DR=DR_"14EXTENDED DESCRIPTION;3QTY;2;4R~UNIT OF ISSUE;11////C;7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"""
D ^DIE Q:$D(DTOUT) K NUM,DA,NEW,Y,DR Q
NFRM ;S DR=DR_"16;8TYPE OF TRANSACTION;9PATIENT CATEGORY;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;3QTY;2;4UNIT OF ISSUE;11////C;"
;S DR=DR_"7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"";"
S DR=DR_"16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);3QTY;2;4UNIT OF ISSUE;11////C;"
S DR=DR_"7REMARKS (2319 and 1358)"
D ^DIE K NUM,DA,NEW,Y,DR Q
TMC ;GET HOURS AND MINUTES BETWEEN START AND CLOSE DATES
S RB="."_$P(RMPRDATE,".",2)*100,RA="."_$P(RMPRCD,".",2)*100
S RC=RA-RB I '$P(RB,".",2) S RC=$P(RC,".")_"."_$S($L($P(RA,".",2))=1:$P(RA,".",2)_"0",1:$P(RA,".",2)) G TXT
S RH=$P(RC,"."),RM="."_$P(RC,".",2) S:RM>.60 RM=(.60)-(1-RM) S RC=RH_$S($L(RM)=2:RM_"0",1:RM)
TXT Q:$D(RMPRGEC) S RC=$S($P(RC,"."):+$P(RC,".")_" Hr "_+$P(RC,".",2)_" Min ",1:+$P(RC,".",2)_" Min ") Q
CHK ;ASK TO ADD DUPLICATE TO 2421 AND NO FORM
K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I X["Y"!(X["y") G FILE
S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1
LKP ;DISPLAY DUPLICATE AND SINGLE ITEMS ON 2421 AND NO FORM
I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP
.F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$P(RD(RDA),U,3)
.K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y
G ENT
STA() ;CONVERTS RMPR("STA") INTO EXTERNAL FORMAT
N STAE I '$D(RMPRSITE)!'($D(RMPR)) D ^RMPRSIT
S STAE=$S($D(^DIC(4,RMPR("STA"),99)):$P(^(99),U),1:RMPR("STA"))
Q STAE
ROU(RMPRSITE) ;Return mail routing code for a site
N RMPRSYM
S RMPRSYM=""
I $G(RMPRSITE)="" G ROUX
S RMPRSYM=$P($G(^RMPR(669.9,RMPRSITE,0)),"^",13)
ROUX Q RMPRSYM
STATN(RSTA) ;CONVERT POINTER TO STATION TO NAME OF STATION
;VARIABLE PASSED IN: RSTA - POINTER TO STATION IN FILE 4
;VARIABLE PASSED OUT:RSTATION - NAME OF STATION
Q:$G(RSTA)'>0 ""
N RSTATION
S RSTATION=$S($D(^DIC(4,RSTA,99)):$P(^(99),U,1),1:RSTA)
Q RSTATION
;
DIC660 ;REVERSE DIC LOOK UP FOR 660.
K ^TMP($J),RMIEN W ! S DIC="^RMPR(665,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: "
D ^DIC G:+Y'>0!($D(DTOUT)) EXIT
REV ; Added for reverse look-up..
S I=0 F S I=$O(^RMPR(660,"C",+Y,I)) Q:I'>0 I $D(^RMPR(660,I,0)) S:$P(^(0),U,6)!($P(^(0),U,26)'="") ^TMP($J,9999999-$P($G(^RMPR(660,I,0)),U,1),I)=I
LST S (I,RMI,RMQUIT,RMSEL,RMIEN)=0 W !,"CHOOSE FROM:"
F S I=$O(^TMP($J,I)) Q:I'>0!(RMQUIT)!(RMSEL)!(RMIEN) S J=0 F S J=$O(^TMP($J,I,J)) Q:J'>0 S RMI=RMI+1,^TMP($J,RMI)=I_"^"_J D WRI I '(RMI#17) D DIS Q:(RMSEL)!(RMQUIT)!(RMIEN)
G:RMSEL LST G:RMIEN PROC I 'RMI W !!,"***PATIENT HAS NO 2319 RECORD!!!!" G EXIT
I RMQUIT W !!,"***** NO SELECTION MADE!!!" G EXIT
W !!,"[<RETURN> or '^' to Quit] or Choose Number 1-",RMI W ": " R X:DTIME I '$T G EXIT
I X=""!(X="^")!('$D(X)) W !!,"***** NO SELECTION MADE!!!" G EXIT
I '$D(^TMP($J,+X)) W !,$C(7),"****INVALID RESPONSE, Please choose a NUMBER within the range!!!!",! G LST
S RMIEN=$P(^TMP($J,+X),U,2)
PROC S Y=+RMIEN,RO=$G(^RMPR(660,+Y,0)),Y=$P(^(0),U,1),RMDFN=0 S:$P(RO,U,2) RMDFN=$P(RO,U,2) X ^DD("DD")
W " ",Y," ",$S(RMDFN:$E($P(^DPT(RMDFN,0),U,1),1,20),1:"")," $",$J($P(RO,U,16),0,2)
EXIT K DIC,DIE,DIR,%,X,RMI,RMIT,RMSEL,RMQUIT,RMDFN,RO,Y,^TMP($J) Q
WRI ;WRITE REVERSE LISTING
S (RMIT,RMDFN)=0 S RO=$G(^RMPR(660,J,0)),Y=$P(^(0),U,1) X ^DD("DD") S:$P(RO,U,6) RMIT=$P(^RMPR(661,$P(RO,U,6),0),U,1) S:$P(RO,U,2) RMDFN=$P(RO,U,2)
W !,$J(RMI,4),"> ",Y,?20,$S(RMDFN:$E($P($G(^DPT(RMDFN,0)),U,1),1,20),1:"")
I $P(RO,U,26)'="" W ?41,$S($P(RO,U,26)="P":"SHIPPING",$P(RO,U,26)="D":"DELIVERY",1:"SHIPPING")
E W ?41,$S(RMIT:$E($P($G(^PRC(441,RMIT,0)),U,2),1,25),1:"")
W ?68,"$",$J($P(RO,U,16),0,2) Q
DIS W !!,"<RETURN> to Continue, '^' to Quit or Choose Number 1-",RMI W ": " R X:DTIME I '$T S RMQUIT=1 Q
Q:X=""!(X=" ") I X="^" S RMQUIT=1 Q
I '$D(^TMP($J,+X)) W !,$C(7),"*****INVALID RESPONSE, Please choose a NUMBER within the range!!!!" S RMSEL=1 Q
S RMIEN=$P(^TMP($J,+X),U,2) Q
;
KILLG ;kill & set 'G' cross reference in 660.
S RMPRBE=$P(^RMPR(660,DA,0),U,22)
K ^RMPR(660,"G",RMPRBE,DA)
S $P(^RMPR(660,DA,0),U,22)=$P(^RMPR(661.1,X,0),U,4),RMPRX=X
S DIK=DIE,DIK(1)="4.1^G" D IX^DIK S X=RMPRX K RMPRX,RMPRBE,RMPRDA
Q
;
121 ;set 121 as the mail routing symbol.
N RMII,RMIIDAT,DIE
S DIE="^RMPR(669.9,",DR="34///^S X=121"
F RMII=0:0 S RMII=$O(^RMPR(669.9,RMII)) Q:RMII'>0 S RMIIDAT=$G(^RMPR(699.9,RMII,0)) I $D(RMIIDAT) S DA=RMII D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRUTIL 7275 printed Dec 13, 2024@02:37:58 Page 2
RMPRUTIL ;PHX/JLT,DLG,HPL,RVD-UTILITY PROGRAMS FOR PROSTHETICS ;10/19/1993
+1 ;;3.0;PROSTHETICS;**12,28,30,44,41,55**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 55 - 1/29/01 - create extrinsic to return mail routing
+4 ; code parameter. (see AUG-1097-32118)
+5 ; RVD - patch 55 - 3/15/01 - initially set the value of 121 as the
+6 ; mail routing symbol @ the post init.
+7 ;
GETPAT ;MAIN ENTRY POINT FOR PATIENT LOOKUPS
+1 KILL RMPRDFN,RMPRSSN,RMPRSSNE,RMPRDOB
+2 NEW DIC,Y,DLAYGO,VAHOW
SET DIC="^RMPR(665,"
SET DIC(0)="AEMLQ"
SET DLAYGO=665
SET DIC("A")="Select PROSTHETIC PATIENT: "
DO ^DIC
KILL DIC,DLAYGO
+3 if $GET(Y)'>0
QUIT
+4 if +Y>0
SET (RMPRDFN,DFN)=+Y
DO DEM^VADPT
DO ELIG^VADPT
+5 ;set prosthetic variables
+6 ;rmprssn is number nnnnnnnnn
+7 ;rmprssne is external format of ssn nnn-nn-nnnn
+8 SET RMPRNAM=$PIECE(VADM(1),U)
SET RMPRSSN=$PIECE(VADM(2),U)
+9 SET RMPRDOB=$PIECE(VADM(3),U)
SET RMPRSSNE=VA("PID")
+10 SET RMPRCNUM=VAEL(7)
+11 IF +VADM(6)
SET RMPRDOD=$PIECE(VADM(6),U)
WRITE !!,$CHAR(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$PIECE(VADM(6),U,2)
+12 IF $DATA(RMPRDOD)
SET DIR(0)="Y"
SET DIR("A")="Would you Like to continue Processing this Patient"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF +Y=0
KILL RMPRDFN
+13 KILL RMPRDOD
DO KVAR^VADPT
QUIT
COMP ;LOOKUP FOR ADDRESS ON PATIENT 10-2319
+1 SET DFN=RMPRDFN
SET VAPA("P")=""
DO ADD^VADPT
+2 SET J=1
FOR I=1:1:3
if VAPA(I)'=""
SET XP(J)=VAPA(I)
SET J=J+1
+3 SET XP(J)=$PIECE(VAPA(4),U)_", "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(6),U,1)
+4 if XP(J)=", "
SET XP(J)=""
if XP(J)]""
SET J=J+1
if XP(1)=""
SET XP(J)="NO ADDRESS ON FILE"
SET J=2
+5 KILL VAPA
SET DFN=RMPRDFN
DO ADD^VADPT
+6 SET J1=1
FOR I=1:1:3
if VAPA(I)'=""
SET X1(J1)=VAPA(I)
SET J1=J1+1
+7 SET X1(J1)=$PIECE(VAPA(4),U)_", "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(6),U)
+8 if X1(J1)=", "
SET X1(J1)=""
if X1(1)=""
SET X1(J1)="NO ADDRESS ON FILE"
SET J1=J1+1
QUIT
EDT ;ENTER/EDIT 2421 AND NO-FORM
+1 SET HY=+Y
IF '$DATA(^RMPR(664,RMPRA,1))
SET ^RMPR(664,RMPRA,1,0)="^664.02PA^0^0"
GOTO FILE
+2 IF $DATA(^RMPR(664,RMPRA,1,"B",+Y))
SET DA=$ORDER(^RMPR(664,RMPRA,1,"B",+Y,0))
GOTO CHK
FILE SET Y=HY
SET NUM=$PIECE(^RMPR(664,RMPRA,1,0),U,4)+1
SET $PIECE(^(0),U,4)=NUM
SET $PIECE(^(0),U,3)=$PIECE(^(0),U,3)+1
SET ^RMPR(664,RMPRA,1,NUM,0)=+Y
SET DA=NUM
SET ^RMPR(664,RMPRA,1,"B",+Y,NUM)=""
SET NEW=1
ENT KILL DR,DQ
SET DA(1)=RMPRA
SET DIE="^RMPR(664,"_RMPRA_",1,"
SET DR=$SELECT($DATA(NEW):"",1:".01;")
KILL NEW
IF RMPRDR'["2421"
GOTO NFRM
+1 SET DR=DR_"16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
+2 SET DR=DR_"14;3;2;4R;11////C;7REMARKS (2319 and 1358)"
+3 ;S DR=DR_"16;8;9;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
+4 ;S DR=DR_"14EXTENDED DESCRIPTION;3QTY;2;4R~UNIT OF ISSUE;11////C;7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"""
+5 DO ^DIE
if $DATA(DTOUT)
QUIT
KILL NUM,DA,NEW,Y,DR
QUIT
NFRM ;S DR=DR_"16;8TYPE OF TRANSACTION;9PATIENT CATEGORY;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;3QTY;2;4UNIT OF ISSUE;11////C;"
+1 ;S DR=DR_"7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"";"
+2 SET DR=DR_"16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);3QTY;2;4UNIT OF ISSUE;11////C;"
+3 SET DR=DR_"7REMARKS (2319 and 1358)"
+4 DO ^DIE
KILL NUM,DA,NEW,Y,DR
QUIT
TMC ;GET HOURS AND MINUTES BETWEEN START AND CLOSE DATES
+1 SET RB="."_$PIECE(RMPRDATE,".",2)*100
SET RA="."_$PIECE(RMPRCD,".",2)*100
+2 SET RC=RA-RB
IF '$PIECE(RB,".",2)
SET RC=$PIECE(RC,".")_"."_$SELECT($LENGTH($PIECE(RA,".",2))=1:$PIECE(RA,".",2)_"0",1:$PIECE(RA,".",2))
GOTO TXT
+3 SET RH=$PIECE(RC,".")
SET RM="."_$PIECE(RC,".",2)
if RM>.60
SET RM=(.60)-(1-RM)
SET RC=RH_$SELECT($LENGTH(RM)=2:RM_"0",1:RM)
TXT if $DATA(RMPRGEC)
QUIT
SET RC=$SELECT($PIECE(RC,"."):+$PIECE(RC,".")_" Hr "_+$PIECE(RC,".",2)_" Min ",1:+$PIECE(RC,".",2)_" Min ")
QUIT
CHK ;ASK TO ADD DUPLICATE TO 2421 AND NO FORM
+1 KILL DIR,Y
SET DIR(0)="S^Y:YES;N:NO"
SET DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?"
SET DIR("B")="NO"
DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
IF X["Y"!(X["y")
GOTO FILE
+2 SET RD=0
FOR RDA=0:0
SET RDA=$ORDER(^RMPR(664,RMPRA,1,"B",HY,RDA))
if RDA'>0
QUIT
SET RD=RD+1
LKP ;DISPLAY DUPLICATE AND SINGLE ITEMS ON 2421 AND NO FORM
+1 IF RD>1
Begin DoDot:1
+2 FOR RDA=0:0
SET RDA=$ORDER(^RMPR(664,RMPRA,1,"B",HY,RDA))
if RDA'>0
QUIT
SET RD(RDA)=^RMPR(664,RMPRA,1,RDA,0)
WRITE !?5,RDA,?10,$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(RD(RDA),U),0),U),0),U,2)," $",$PIECE(RD(RDA),U,3)
+3 KILL DIR,Y
SET DIR(0)="N"
DO ^DIR
IF +Y
SET DA=+Y
End DoDot:1
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
IF '$DATA(RD(+Y))
WRITE $CHAR(7)
GOTO LKP
+4 GOTO ENT
STA() ;CONVERTS RMPR("STA") INTO EXTERNAL FORMAT
+1 NEW STAE
IF '$DATA(RMPRSITE)!'($DATA(RMPR))
DO ^RMPRSIT
+2 SET STAE=$SELECT($DATA(^DIC(4,RMPR("STA"),99)):$PIECE(^(99),U),1:RMPR("STA"))
+3 QUIT STAE
ROU(RMPRSITE) ;Return mail routing code for a site
+1 NEW RMPRSYM
+2 SET RMPRSYM=""
+3 IF $GET(RMPRSITE)=""
GOTO ROUX
+4 SET RMPRSYM=$PIECE($GET(^RMPR(669.9,RMPRSITE,0)),"^",13)
ROUX QUIT RMPRSYM
STATN(RSTA) ;CONVERT POINTER TO STATION TO NAME OF STATION
+1 ;VARIABLE PASSED IN: RSTA - POINTER TO STATION IN FILE 4
+2 ;VARIABLE PASSED OUT:RSTATION - NAME OF STATION
+3 if $GET(RSTA)'>0
QUIT ""
+4 NEW RSTATION
+5 SET RSTATION=$SELECT($DATA(^DIC(4,RSTA,99)):$PIECE(^(99),U,1),1:RSTA)
+6 QUIT RSTATION
+7 ;
DIC660 ;REVERSE DIC LOOK UP FOR 660.
+1 KILL ^TMP($JOB),RMIEN
WRITE !
SET DIC="^RMPR(665,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select PATIENT: "
+2 DO ^DIC
if +Y'>0!($DATA(DTOUT))
GOTO EXIT
REV ; Added for reverse look-up..
+1 SET I=0
FOR
SET I=$ORDER(^RMPR(660,"C",+Y,I))
if I'>0
QUIT
IF $DATA(^RMPR(660,I,0))
if $PIECE(^(0),U,6)!($PIECE(^(0),U,26)'="")
SET ^TMP($JOB,9999999-$PIECE($GET(^RMPR(660,I,0)),U,1),I)=I
LST SET (I,RMI,RMQUIT,RMSEL,RMIEN)=0
WRITE !,"CHOOSE FROM:"
+1 FOR
SET I=$ORDER(^TMP($JOB,I))
if I'>0!(RMQUIT)!(RMSEL)!(RMIEN)
QUIT
SET J=0
FOR
SET J=$ORDER(^TMP($JOB,I,J))
if J'>0
QUIT
SET RMI=RMI+1
SET ^TMP($JOB,RMI)=I_"^"_J
DO WRI
IF '(RMI#17)
DO DIS
if (RMSEL)!(RMQUIT)!(RMIEN)
QUIT
+2 if RMSEL
GOTO LST
if RMIEN
GOTO PROC
IF 'RMI
WRITE !!,"***PATIENT HAS NO 2319 RECORD!!!!"
GOTO EXIT
+3 IF RMQUIT
WRITE !!,"***** NO SELECTION MADE!!!"
GOTO EXIT
+4 WRITE !!,"[<RETURN> or '^' to Quit] or Choose Number 1-",RMI
WRITE ": "
READ X:DTIME
IF '$TEST
GOTO EXIT
+5 IF X=""!(X="^")!('$DATA(X))
WRITE !!,"***** NO SELECTION MADE!!!"
GOTO EXIT
+6 IF '$DATA(^TMP($JOB,+X))
WRITE !,$CHAR(7),"****INVALID RESPONSE, Please choose a NUMBER within the range!!!!",!
GOTO LST
+7 SET RMIEN=$PIECE(^TMP($JOB,+X),U,2)
PROC SET Y=+RMIEN
SET RO=$GET(^RMPR(660,+Y,0))
SET Y=$PIECE(^(0),U,1)
SET RMDFN=0
if $PIECE(RO,U,2)
SET RMDFN=$PIECE(RO,U,2)
XECUTE ^DD("DD")
+1 WRITE " ",Y," ",$SELECT(RMDFN:$EXTRACT($PIECE(^DPT(RMDFN,0),U,1),1,20),1:"")," $",$JUSTIFY($PIECE(RO,U,16),0,2)
EXIT KILL DIC,DIE,DIR,%,X,RMI,RMIT,RMSEL,RMQUIT,RMDFN,RO,Y,^TMP($JOB)
QUIT
WRI ;WRITE REVERSE LISTING
+1 SET (RMIT,RMDFN)=0
SET RO=$GET(^RMPR(660,J,0))
SET Y=$PIECE(^(0),U,1)
XECUTE ^DD("DD")
if $PIECE(RO,U,6)
SET RMIT=$PIECE(^RMPR(661,$PIECE(RO,U,6),0),U,1)
if $PIECE(RO,U,2)
SET RMDFN=$PIECE(RO,U,2)
+2 WRITE !,$JUSTIFY(RMI,4),"> ",Y,?20,$SELECT(RMDFN:$EXTRACT($PIECE($GET(^DPT(RMDFN,0)),U,1),1,20),1:"")
+3 IF $PIECE(RO,U,26)'=""
WRITE ?41,$SELECT($PIECE(RO,U,26)="P":"SHIPPING",$PIECE(RO,U,26)="D":"DELIVERY",1:"SHIPPING")
+4 IF '$TEST
WRITE ?41,$SELECT(RMIT:$EXTRACT($PIECE($GET(^PRC(441,RMIT,0)),U,2),1,25),1:"")
+5 WRITE ?68,"$",$JUSTIFY($PIECE(RO,U,16),0,2)
QUIT
DIS WRITE !!,"<RETURN> to Continue, '^' to Quit or Choose Number 1-",RMI
WRITE ": "
READ X:DTIME
IF '$TEST
SET RMQUIT=1
QUIT
+1 if X=""!(X=" ")
QUIT
IF X="^"
SET RMQUIT=1
QUIT
+2 IF '$DATA(^TMP($JOB,+X))
WRITE !,$CHAR(7),"*****INVALID RESPONSE, Please choose a NUMBER within the range!!!!"
SET RMSEL=1
QUIT
+3 SET RMIEN=$PIECE(^TMP($JOB,+X),U,2)
QUIT
+4 ;
KILLG ;kill & set 'G' cross reference in 660.
+1 SET RMPRBE=$PIECE(^RMPR(660,DA,0),U,22)
+2 KILL ^RMPR(660,"G",RMPRBE,DA)
+3 SET $PIECE(^RMPR(660,DA,0),U,22)=$PIECE(^RMPR(661.1,X,0),U,4)
SET RMPRX=X
+4 SET DIK=DIE
SET DIK(1)="4.1^G"
DO IX^DIK
SET X=RMPRX
KILL RMPRX,RMPRBE,RMPRDA
+5 QUIT
+6 ;
121 ;set 121 as the mail routing symbol.
+1 NEW RMII,RMIIDAT,DIE
+2 SET DIE="^RMPR(669.9,"
SET DR="34///^S X=121"
+3 FOR RMII=0:0
SET RMII=$ORDER(^RMPR(669.9,RMII))
if RMII'>0
QUIT
SET RMIIDAT=$GET(^RMPR(699.9,RMII,0))
IF $DATA(RMIIDAT)
SET DA=RMII
DO ^DIE
+4 QUIT
