RMPRPCEL ;HCIOFO/RVD - LINK SUSPENSE UTILITY; 08/14/01
;;3.0;PROSTHETICS;**62,69**;Feb 09, 1996
;
;RVD patch #69 4/17/02 - prevent error if record in 668 is not complete
; for 2319 linking.
;This routine contains the code for linking file #660 and #668.
;Link the selected suspense to a corresponding 2319 record(s).
;And call routine for updating #660 and #668
;
;Variables need for this subroutine:
; ^TMP($J,"RMPRPCE",660
; ^TMP($J,"RMPRPCE",668
LINK60 ;link suspense to 2319 records
SEL60 ;
K RMSUS60
S RMSULINK=DA
D NEWVAR
W !!,"List of 2319 Records:"
S (RM60CNT,RMSERR)=0
F RMSI=0:0 S RMSI=$O(^TMP($J,"RMPRPCE",660,RMSI)) Q:RMSI'>0 D
.I $D(^RMPR(660,RMSI,0)) S RM60CNT=RM60CNT+1,RMSUS60(RM60CNT)=RMSI
;
RES60 K DIR
S (RMQUIT,RMSCNT,RMNT)=0
F RMSI=0:0 S RMSI=$O(RMSUS60(RMSI)) Q:(RMSI'>0)!(RMQUIT=1) D
.S DIR(0)="E"
.S RMSCNT=RMSCNT+1,RMNT=RMNT+1,(RM60IT,RM60VEN0,RMPRPRC)=""
.S RM60DATA=$G(^RMPR(660,RMSUS60(RMSI),0))
.S RM60DATE=$P(RM60DATA,U,1),RM60ITEM=$P(RM60DATA,U,6)
.S RM60TYPT=$P(RM60DATA,U,4),RM60VEN=$P(RM60DATA,U,9)
.S RM60D=$E(RM60DATE,4,5)_"/"_$E(RM60DATE,6,7)_"/"_$E(RM60DATE,2,3)
.I RM60ITEM,$D(^RMPR(661,RM60ITEM,0)) S RM60IT=$P(^RMPR(661,RM60ITEM,0),U,1)
.I RM60VEN,$D(^PRC(440,RM60VEN,0)) S RM60VEN0=$E($P(^PRC(440,RM60VEN,0),U,1),1,15)
.I RM60VEN,'$D(^PRC(440,RM60VEN,0)) S RM60VEN0=""
.I RM60ITEM,'$D(^RMPR(661,RM60ITEM,0)) S RM60IT=""
.I RM60IT,$D(^PRC(441,RM60IT,0)) S RMPRPRC=$E($P(^PRC(441,RM60IT,0),U,2),1,15)
.W !,?5,RMSI_".",?9,RM60D,?21,RMPRPRC,?39,RM60VEN0
.I RMNT>14 D ^DIR S RMNT=0 I Y'=1 S RMQUIT=1
Q:RMQUIT
S DIR(0)="LO^1:"_RMSCNT
S DIR("A")="Enter 2319 Record to be LINKED "
D ^DIR
I $D(DUOUT)!$D(DTOUT)!$D(DIRUT)!(Y="") W !!,"***NO Link to Suspense!!",!! Q
S RM60L=Y
S RC=0 F S RC=RC+1 S RMD=$P(RM60L,",",RC) Q:RMD="" D
.Q:'$D(RMSUS60(RMD))
.S RMSEL(RMD)=""
.S $P(^TMP($J,"RMPRPCE",660,RMSUS60(RMD)),U,3)=1
.S $P(^TMP($J,"RMPRPCE",660,RMSUS60(RMD)),U,4)=RMSULINK
.K RMSUS60(RMD)
.;S RNT=0 F RMSI=0:0 S RMSI=$O(RMSUS60(RMSI)) Q:RMSI'>0 S RNT=RNT+1 I (RMSI>1),(RNT'=RMSI) S RMSUS60(RNT)=RMSUS60(RMSI) K RMSUS60(RMSI)
;
UPFILE ;call update 660 & 668
;process link to suspense, update field in file #660.
S RMSCHECK=0
F I=0:0 S I=$O(^TMP($J,"RMPRPCE",660,I)) Q:I'>0 D
.S RM60DAT=$G(^TMP($J,"RMPRPCE",660,I))
.S RMSAMIS=$P(RM60DAT,U,1)
.S RMSTATUS=$P(RM60DAT,U,3)
.S RM668=$P(RM60DAT,U,4)
.Q:'$G(RM668)
.Q:'$G(RMSAMIS)
.S RMSCHECK=$$UP60^RMPRPCE1(I,RM668,RMSTATUS)
.S RMSERR=$$UP68^RMPRPCE1(I,RM668,RMSAMIS)
.K ^TMP($J,"RMPRPCE",660,I)
K ^TMP($J,"RMPRPCE",668)
S:$G(RMSULINK) DA=RMSULINK
Q
;
SMESS8 ;print/display message for mandatory suspense entry.
W !!,"*********************************************************"
W !,"** No suspense record has been selected for this trans-**"
W !,"** action. You must select an entry from the list to **"
W !,"** complete this transaction, otherwise transaction **"
W !,"** will not be linked to SUSPENSE.................... **"
W !,"*********************************************************"
W !!
Q
;
SMESS0 ;print/display message for 2319 entry.
W !!,"*********************************************************"
W !,"** Patient record(s) still exist...................... **"
W !,"** You must select an entry from the list to complete **"
W !,"** all transactions, otherwise some transactions will **"
W !,"** not be linked to SUSPENSE!!! **"
W !,"*********************************************************"
W !!
Q
;
CDIR K DIR
S DIR(0)="SBO^L:LINK Suspense to Patient Record;E:EXIT without linking to Suspense"
S DIR("A")="Would you like to LINK Suspense or EXIT without linking"
S DIR("B")="L"
S DIR("?")="Answer `L` to Link to suspense, 'E' to exit without linking to suspense"
D ^DIR S RMENTSUS=Y
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) S RMENTSUS="E"
W !! K DIR
Q
;
AUTO ;auto-link a suspense record.
;added by #62
;input rm60link(),rm68link, rgrp1 and rmprdfn
F R6I=0:0 S R6I=$O(RM60LINK(R6I)) Q:R6I'>0 D
.;do auto-link if only one suspense
.Q:'$D(RM68LINK)
.I $D(RM68LINK) S RM668I=$O(RM68LINK(0))
.S ^TMP($J,"RMPRPCE",660,R6I)=$G(RGRP1)_"^"_RMPRDFN_"^"_1_"^"_RM668I
.S ^TMP($J,"RMPRPCE",668,RM668I)=""
.D UPFILE^RMPRPCEL
G KILL
;
MAN ;link record.
;input rm60link(), rgrp1 and rmprdfn
;call suspense listmanager screen for multiple suspense and items.
S RMSUCLFG=1
F R6I=0:0 S R6I=$O(RM60LINK(R6I)) Q:R6I'>0 D
.S ^TMP($J,"RMPRPCE",660,R6I)=$G(RGRP1)_"^"_RMPRDFN
D LINK^RMPRS
G KILL
;
KILL ;kill link variables
K RM60LINK,RM68LINK,R6I,RM668I,RMSUCLFG
Q
;
COL ;collect PREVIOUS items for CO & CPO options only.
;input variable RMPRA
;return variable RM68FG = a flag if previous item is linked.
;if linked, variables RM60LINK & RM68LINK are sets.
S RM68FG=0
F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 S RM664DAT=$G(^RMPR(664,RMPRA,1,RI,0)) I $P(RM664DAT,U,13) D
.S RM660I=$P(RM664DAT,U,13)
.S:$D(^RMPR(660,RM660I,"AMS")) RGRP1=$P(^RMPR(660,RM660I,"AMS"),U,1)
.I $P($G(^RMPR(660,RM660I,10)),U,14) S RM668D10=$O(^RMPR(668,"F",RM660I,0)) D
..I $G(RM668D10),'$D(RM68LINK(RM668D10)) S RM68FG=RM68FG+1,RM68LINK(RM668D10)=""
.I '$D(^RMPR(660,RM660I,10)) S RM60LINK(RM660I)=""
.I $D(^RMPR(660,RM660I,10)),$P(^RMPR(660,RM660I,10),U,1)="" S RM60LINK(RM660I)=""
Q
;
ICDT(R68) ;update the initial and completion date in #660
;input variable R68 = FILE 668 ien
N RMDAT,RM660,RI,RMINDT,RMCODT,RMERROR,DA
Q:'$D(^RMPR(668,R68,10))
F RI=0:0 S RI=$O(^RMPR(668,R68,10,RI)) Q:RI'>0 I $P(^RMPR(668,R68,10,RI,0),U,1) D
.S RM660=$P(^RMPR(668,R68,10,RI,0),U,1)
.I $G(RM660),$D(^RMPR(660,RM660,10)) D
..S RMINDT=$P(^RMPR(668,R68,0),U,9)
..S RMCODT=$P(^RMPR(668,R68,0),U,5)
..S RMDAT(660,RM660_",",8.3)=RMINDT
..S RMDAT(660,RM660_",",8.4)=RMCODT
..D FILE^DIE("","RMDAT","RMERROR")
..I $D(RMERROR) W !!,"*** Error in 2319 Record = ",RM660," !!!",!! Q
Q
;
NEWVAR N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC
N RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS
N RM68CNT,RM60CNT,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD
N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPCEL 6334 printed Sep 23, 2025@20:11:56 Page 2
RMPRPCEL ;HCIOFO/RVD - LINK SUSPENSE UTILITY; 08/14/01
+1 ;;3.0;PROSTHETICS;**62,69**;Feb 09, 1996
+2 ;
+3 ;RVD patch #69 4/17/02 - prevent error if record in 668 is not complete
+4 ; for 2319 linking.
+5 ;This routine contains the code for linking file #660 and #668.
+6 ;Link the selected suspense to a corresponding 2319 record(s).
+7 ;And call routine for updating #660 and #668
+8 ;
+9 ;Variables need for this subroutine:
+10 ; ^TMP($J,"RMPRPCE",660
+11 ; ^TMP($J,"RMPRPCE",668
LINK60 ;link suspense to 2319 records
SEL60 ;
+1 KILL RMSUS60
+2 SET RMSULINK=DA
+3 DO NEWVAR
+4 WRITE !!,"List of 2319 Records:"
+5 SET (RM60CNT,RMSERR)=0
+6 FOR RMSI=0:0
SET RMSI=$ORDER(^TMP($JOB,"RMPRPCE",660,RMSI))
if RMSI'>0
QUIT
Begin DoDot:1
+7 IF $DATA(^RMPR(660,RMSI,0))
SET RM60CNT=RM60CNT+1
SET RMSUS60(RM60CNT)=RMSI
End DoDot:1
+8 ;
RES60 KILL DIR
+1 SET (RMQUIT,RMSCNT,RMNT)=0
+2 FOR RMSI=0:0
SET RMSI=$ORDER(RMSUS60(RMSI))
if (RMSI'>0)!(RMQUIT=1)
QUIT
Begin DoDot:1
+3 SET DIR(0)="E"
+4 SET RMSCNT=RMSCNT+1
SET RMNT=RMNT+1
SET (RM60IT,RM60VEN0,RMPRPRC)=""
+5 SET RM60DATA=$GET(^RMPR(660,RMSUS60(RMSI),0))
+6 SET RM60DATE=$PIECE(RM60DATA,U,1)
SET RM60ITEM=$PIECE(RM60DATA,U,6)
+7 SET RM60TYPT=$PIECE(RM60DATA,U,4)
SET RM60VEN=$PIECE(RM60DATA,U,9)
+8 SET RM60D=$EXTRACT(RM60DATE,4,5)_"/"_$EXTRACT(RM60DATE,6,7)_"/"_$EXTRACT(RM60DATE,2,3)
+9 IF RM60ITEM
IF $DATA(^RMPR(661,RM60ITEM,0))
SET RM60IT=$PIECE(^RMPR(661,RM60ITEM,0),U,1)
+10 IF RM60VEN
IF $DATA(^PRC(440,RM60VEN,0))
SET RM60VEN0=$EXTRACT($PIECE(^PRC(440,RM60VEN,0),U,1),1,15)
+11 IF RM60VEN
IF '$DATA(^PRC(440,RM60VEN,0))
SET RM60VEN0=""
+12 IF RM60ITEM
IF '$DATA(^RMPR(661,RM60ITEM,0))
SET RM60IT=""
+13 IF RM60IT
IF $DATA(^PRC(441,RM60IT,0))
SET RMPRPRC=$EXTRACT($PIECE(^PRC(441,RM60IT,0),U,2),1,15)
+14 WRITE !,?5,RMSI_".",?9,RM60D,?21,RMPRPRC,?39,RM60VEN0
+15 IF RMNT>14
DO ^DIR
SET RMNT=0
IF Y'=1
SET RMQUIT=1
End DoDot:1
+16 if RMQUIT
QUIT
+17 SET DIR(0)="LO^1:"_RMSCNT
+18 SET DIR("A")="Enter 2319 Record to be LINKED "
+19 DO ^DIR
+20 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIRUT)!(Y="")
WRITE !!,"***NO Link to Suspense!!",!!
QUIT
+21 SET RM60L=Y
+22 SET RC=0
FOR
SET RC=RC+1
SET RMD=$PIECE(RM60L,",",RC)
if RMD=""
QUIT
Begin DoDot:1
+23 if '$DATA(RMSUS60(RMD))
QUIT
+24 SET RMSEL(RMD)=""
+25 SET $PIECE(^TMP($JOB,"RMPRPCE",660,RMSUS60(RMD)),U,3)=1
+26 SET $PIECE(^TMP($JOB,"RMPRPCE",660,RMSUS60(RMD)),U,4)=RMSULINK
+27 KILL RMSUS60(RMD)
+28 ;S RNT=0 F RMSI=0:0 S RMSI=$O(RMSUS60(RMSI)) Q:RMSI'>0 S RNT=RNT+1 I (RMSI>1),(RNT'=RMSI) S RMSUS60(RNT)=RMSUS60(RMSI) K RMSUS60(RMSI)
End DoDot:1
+29 ;
UPFILE ;call update 660 & 668
+1 ;process link to suspense, update field in file #660.
+2 SET RMSCHECK=0
+3 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"RMPRPCE",660,I))
if I'>0
QUIT
Begin DoDot:1
+4 SET RM60DAT=$GET(^TMP($JOB,"RMPRPCE",660,I))
+5 SET RMSAMIS=$PIECE(RM60DAT,U,1)
+6 SET RMSTATUS=$PIECE(RM60DAT,U,3)
+7 SET RM668=$PIECE(RM60DAT,U,4)
+8 if '$GET(RM668)
QUIT
+9 if '$GET(RMSAMIS)
QUIT
+10 SET RMSCHECK=$$UP60^RMPRPCE1(I,RM668,RMSTATUS)
+11 SET RMSERR=$$UP68^RMPRPCE1(I,RM668,RMSAMIS)
+12 KILL ^TMP($JOB,"RMPRPCE",660,I)
End DoDot:1
+13 KILL ^TMP($JOB,"RMPRPCE",668)
+14 if $GET(RMSULINK)
SET DA=RMSULINK
+15 QUIT
+16 ;
SMESS8 ;print/display message for mandatory suspense entry.
+1 WRITE !!,"*********************************************************"
+2 WRITE !,"** No suspense record has been selected for this trans-**"
+3 WRITE !,"** action. You must select an entry from the list to **"
+4 WRITE !,"** complete this transaction, otherwise transaction **"
+5 WRITE !,"** will not be linked to SUSPENSE.................... **"
+6 WRITE !,"*********************************************************"
+7 WRITE !!
+8 QUIT
+9 ;
SMESS0 ;print/display message for 2319 entry.
+1 WRITE !!,"*********************************************************"
+2 WRITE !,"** Patient record(s) still exist...................... **"
+3 WRITE !,"** You must select an entry from the list to complete **"
+4 WRITE !,"** all transactions, otherwise some transactions will **"
+5 WRITE !,"** not be linked to SUSPENSE!!! **"
+6 WRITE !,"*********************************************************"
+7 WRITE !!
+8 QUIT
+9 ;
CDIR KILL DIR
+1 SET DIR(0)="SBO^L:LINK Suspense to Patient Record;E:EXIT without linking to Suspense"
+2 SET DIR("A")="Would you like to LINK Suspense or EXIT without linking"
+3 SET DIR("B")="L"
+4 SET DIR("?")="Answer `L` to Link to suspense, 'E' to exit without linking to suspense"
+5 DO ^DIR
SET RMENTSUS=Y
+6 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
SET RMENTSUS="E"
+7 WRITE !!
KILL DIR
+8 QUIT
+9 ;
AUTO ;auto-link a suspense record.
+1 ;added by #62
+2 ;input rm60link(),rm68link, rgrp1 and rmprdfn
+3 FOR R6I=0:0
SET R6I=$ORDER(RM60LINK(R6I))
if R6I'>0
QUIT
Begin DoDot:1
+4 ;do auto-link if only one suspense
+5 if '$DATA(RM68LINK)
QUIT
+6 IF $DATA(RM68LINK)
SET RM668I=$ORDER(RM68LINK(0))
+7 SET ^TMP($JOB,"RMPRPCE",660,R6I)=$GET(RGRP1)_"^"_RMPRDFN_"^"_1_"^"_RM668I
+8 SET ^TMP($JOB,"RMPRPCE",668,RM668I)=""
+9 DO UPFILE^RMPRPCEL
End DoDot:1
+10 GOTO KILL
+11 ;
MAN ;link record.
+1 ;input rm60link(), rgrp1 and rmprdfn
+2 ;call suspense listmanager screen for multiple suspense and items.
+3 SET RMSUCLFG=1
+4 FOR R6I=0:0
SET R6I=$ORDER(RM60LINK(R6I))
if R6I'>0
QUIT
Begin DoDot:1
+5 SET ^TMP($JOB,"RMPRPCE",660,R6I)=$GET(RGRP1)_"^"_RMPRDFN
End DoDot:1
+6 DO LINK^RMPRS
+7 GOTO KILL
+8 ;
KILL ;kill link variables
+1 KILL RM60LINK,RM68LINK,R6I,RM668I,RMSUCLFG
+2 QUIT
+3 ;
COL ;collect PREVIOUS items for CO & CPO options only.
+1 ;input variable RMPRA
+2 ;return variable RM68FG = a flag if previous item is linked.
+3 ;if linked, variables RM60LINK & RM68LINK are sets.
+4 SET RM68FG=0
+5 FOR RI=0:0
SET RI=$ORDER(^RMPR(664,RMPRA,1,RI))
if RI'>0
QUIT
SET RM664DAT=$GET(^RMPR(664,RMPRA,1,RI,0))
IF $PIECE(RM664DAT,U,13)
Begin DoDot:1
+6 SET RM660I=$PIECE(RM664DAT,U,13)
+7 if $DATA(^RMPR(660,RM660I,"AMS"))
SET RGRP1=$PIECE(^RMPR(660,RM660I,"AMS"),U,1)
+8 IF $PIECE($GET(^RMPR(660,RM660I,10)),U,14)
SET RM668D10=$ORDER(^RMPR(668,"F",RM660I,0))
Begin DoDot:2
+9 IF $GET(RM668D10)
IF '$DATA(RM68LINK(RM668D10))
SET RM68FG=RM68FG+1
SET RM68LINK(RM668D10)=""
End DoDot:2
+10 IF '$DATA(^RMPR(660,RM660I,10))
SET RM60LINK(RM660I)=""
+11 IF $DATA(^RMPR(660,RM660I,10))
IF $PIECE(^RMPR(660,RM660I,10),U,1)=""
SET RM60LINK(RM660I)=""
End DoDot:1
+12 QUIT
+13 ;
ICDT(R68) ;update the initial and completion date in #660
+1 ;input variable R68 = FILE 668 ien
+2 NEW RMDAT,RM660,RI,RMINDT,RMCODT,RMERROR,DA
+3 if '$DATA(^RMPR(668,R68,10))
QUIT
+4 FOR RI=0:0
SET RI=$ORDER(^RMPR(668,R68,10,RI))
if RI'>0
QUIT
IF $PIECE(^RMPR(668,R68,10,RI,0),U,1)
Begin DoDot:1
+5 SET RM660=$PIECE(^RMPR(668,R68,10,RI,0),U,1)
+6 IF $GET(RM660)
IF $DATA(^RMPR(660,RM660,10))
Begin DoDot:2
+7 SET RMINDT=$PIECE(^RMPR(668,R68,0),U,9)
+8 SET RMCODT=$PIECE(^RMPR(668,R68,0),U,5)
+9 SET RMDAT(660,RM660_",",8.3)=RMINDT
+10 SET RMDAT(660,RM660_",",8.4)=RMCODT
+11 DO FILE^DIE("","RMDAT","RMERROR")
+12 IF $DATA(RMERROR)
WRITE !!,"*** Error in 2319 Record = ",RM660," !!!",!!
QUIT
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
NEWVAR NEW DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC
+1 NEW RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS
+2 NEW RM68CNT,RM60CNT,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD
+3 NEW RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT
+4 QUIT
