RMPREOL ;HINES/RVD SUSPENSE PROCESSING/LINK TO 2319 ; 14-AUG-2001
;;3.0;PROSTHETICS;**62,83**;Feb 09, 1996;Build 20
;
;HNC #83 add free text ordering provider 3/11/05
;
; RVD patch #62 - new routine for suspense list template.
; if link to 2319 record is needed.
EN ; -- main entry point for RMPREO
D ^%ZISC
N STRING,CLREND,COLUMN,LINE,ON,OFF
;get patient to test with
K ^TMP($J,"RMPREO")
K ^TMP($J,"RMPREOEE")
;ask station
I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
I '$D(RMPRDFN) D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
D EN^VALM("RMPREO LINK 2319")
Q
;
HDR ; -- header code
N VA,VADM
S DFN=RMPRDFN
D DEM^VADPT
;S VALMHDR(1)="Suspense Processing"
S VALMHDR(1)="Open/Pending/Closed Suspense for "_$$LOWER^VALM1(VADM(1))_" ("_$P(VADM(2),U,2)_")"
D KVAR^VADPT
K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
Q
;
INIT ; -- init variables and list array
K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
D HDR
N RMPRA,CDATE,LINE,X
;start loop
;
K ADATE,PDAY
S RMPRA="",VALMCNT=0,RRX=""
;reverse order display
F S RMPRA=$O(^RMPR(668,"C",RMPRDFN,RMPRA),-1) Q:RMPRA="" D
.I $P(^RMPR(668,RMPRA,0),U,10)="X" Q
.I $G(RMSUCLFG),'$D(RM68LINK(RMPRA)) Q
.S VALMCNT=VALMCNT+1,LINE=VALMCNT
.S RRX=$$SETFLD^VALM1(LINE,RRX,"LINE")
.S CDATE=$P(^RMPR(668,RMPRA,0),U,1),CDATE=$$DAT1^RMPRUTL1(CDATE)
.S RRX=$$SETFLD^VALM1(CDATE,RRX,"DATE")
.S WHO1=""
.I $P(^RMPR(668,RMPRA,0),U,11)'="" S WHO1=$$WHO^RMPREOU($P(^RMPR(668,RMPRA,0),U,11),12)
.I $P($G(^RMPR(668,RMPRA,"IFC1")),U,3)'="" S WHO1=$$WHO^RMPREOU("",12,RMPRA)
.;
.S RRX=$$SETFLD^VALM1(WHO1,RRX,"WHO")
.K WHO,WHO1
.;type
.S TYPE=$$TYPE^RMPREOU(RMPRA,8)
.S RRX=$$SETFLD^VALM1(TYPE,RRX,"TYPE")
.;display description if manual
.;
.S RRX=$$SETFLD^VALM1($$DES^RMPREOU(RMPRA,22),RRX,"DES")
.;init activation date
.S ADATE="",PDAY="",WRKDAY=""
.S ADATE=$P(^RMPR(668,RMPRA,0),U,9)
.I ADATE'="" S (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA)
.I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA)
.S RRX=$$SETFLD^VALM1($$DAT1^RMPRUTL1(ADATE),RRX,"INITIAL ACTION DATE")
.I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA) I CDAY>7 S PDAY="*"_WRKDAY
.I ADATE=""&(WRKDAY>5) S PDAY="@"_WRKDAY
.S RRX=$$SETFLD^VALM1(PDAY,RRX,"PDAY")
.K ADATE,PDAY,WRKDAY,CDAY
.;S R660=""
.;F S R660=$O(^RMPR(668,RMPRA,6,"B",R660)) Q:R660'>0 D
.; .S RRX=$$SETFLD^VALM1($$ITEM^RMPREOU(R660,17),RRX,"ITEM")
.S RRX=$$SETFLD^VALM1($$STATUS^RMPREOU(RMPRA,7),RRX,"STATUS")
.S ^TMP($J,"RMPREO",LINE,0)=RRX
.S ^TMP($J,"RMPREOEE",LINE,0)=RMPRA
Q
;
;
SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ;set array
I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLUMN,$L(STRING),ON,OFF)
Q
;
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
;NOT XUSCLEAN
;added by patch #62
;if transaction still exist for linking, print message and re-link
I $D(^TMP($J,"RMPRPCE")) D G:RMENTSUS="L" EN
.S RMQUIT=0
.W @IOF D SMESS0^RMPRPCEL,CDIR^RMPRPCEL
K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
Q
;
EXPND ; -- expand code
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPREOL 3195 printed Oct 16, 2024@18:35:05 Page 2
RMPREOL ;HINES/RVD SUSPENSE PROCESSING/LINK TO 2319 ; 14-AUG-2001
+1 ;;3.0;PROSTHETICS;**62,83**;Feb 09, 1996;Build 20
+2 ;
+3 ;HNC #83 add free text ordering provider 3/11/05
+4 ;
+5 ; RVD patch #62 - new routine for suspense list template.
+6 ; if link to 2319 record is needed.
EN ; -- main entry point for RMPREO
+1 DO ^%ZISC
+2 NEW STRING,CLREND,COLUMN,LINE,ON,OFF
+3 ;get patient to test with
+4 KILL ^TMP($JOB,"RMPREO")
+5 KILL ^TMP($JOB,"RMPREOEE")
+6 ;ask station
+7 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+8 IF '$DATA(RMPRDFN)
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
QUIT
+9 DO EN^VALM("RMPREO LINK 2319")
+10 QUIT
+11 ;
HDR ; -- header code
+1 NEW VA,VADM
+2 SET DFN=RMPRDFN
+3 DO DEM^VADPT
+4 ;S VALMHDR(1)="Suspense Processing"
+5 SET VALMHDR(1)="Open/Pending/Closed Suspense for "_$$LOWER^VALM1(VADM(1))_" ("_$PIECE(VADM(2),U,2)_")"
+6 DO KVAR^VADPT
+7 KILL ^TMP($JOB,"RMPREO"),^TMP($JOB,"RMPREOEE")
+8 QUIT
+9 ;
INIT ; -- init variables and list array
+1 KILL ^TMP($JOB,"RMPREO"),^TMP($JOB,"RMPREOEE")
+2 DO HDR
+3 NEW RMPRA,CDATE,LINE,X
+4 ;start loop
+5 ;
+6 KILL ADATE,PDAY
+7 SET RMPRA=""
SET VALMCNT=0
SET RRX=""
+8 ;reverse order display
+9 FOR
SET RMPRA=$ORDER(^RMPR(668,"C",RMPRDFN,RMPRA),-1)
if RMPRA=""
QUIT
Begin DoDot:1
+10 IF $PIECE(^RMPR(668,RMPRA,0),U,10)="X"
QUIT
+11 IF $GET(RMSUCLFG)
IF '$DATA(RM68LINK(RMPRA))
QUIT
+12 SET VALMCNT=VALMCNT+1
SET LINE=VALMCNT
+13 SET RRX=$$SETFLD^VALM1(LINE,RRX,"LINE")
+14 SET CDATE=$PIECE(^RMPR(668,RMPRA,0),U,1)
SET CDATE=$$DAT1^RMPRUTL1(CDATE)
+15 SET RRX=$$SETFLD^VALM1(CDATE,RRX,"DATE")
+16 SET WHO1=""
+17 IF $PIECE(^RMPR(668,RMPRA,0),U,11)'=""
SET WHO1=$$WHO^RMPREOU($PIECE(^RMPR(668,RMPRA,0),U,11),12)
+18 IF $PIECE($GET(^RMPR(668,RMPRA,"IFC1")),U,3)'=""
SET WHO1=$$WHO^RMPREOU("",12,RMPRA)
+19 ;
+20 SET RRX=$$SETFLD^VALM1(WHO1,RRX,"WHO")
+21 KILL WHO,WHO1
+22 ;type
+23 SET TYPE=$$TYPE^RMPREOU(RMPRA,8)
+24 SET RRX=$$SETFLD^VALM1(TYPE,RRX,"TYPE")
+25 ;display description if manual
+26 ;
+27 SET RRX=$$SETFLD^VALM1($$DES^RMPREOU(RMPRA,22),RRX,"DES")
+28 ;init activation date
+29 SET ADATE=""
SET PDAY=""
SET WRKDAY=""
+30 SET ADATE=$PIECE(^RMPR(668,RMPRA,0),U,9)
+31 IF ADATE'=""
SET (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA)
+32 IF ADATE=""
SET (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA)
+33 SET RRX=$$SETFLD^VALM1($$DAT1^RMPRUTL1(ADATE),RRX,"INITIAL ACTION DATE")
+34 IF ADATE'=""
SET CDAY=$$PDAY^RMPREOU(RMPRA)
IF CDAY>7
SET PDAY="*"_WRKDAY
+35 IF ADATE=""&(WRKDAY>5)
SET PDAY="@"_WRKDAY
+36 SET RRX=$$SETFLD^VALM1(PDAY,RRX,"PDAY")
+37 KILL ADATE,PDAY,WRKDAY,CDAY
+38 ;S R660=""
+39 ;F S R660=$O(^RMPR(668,RMPRA,6,"B",R660)) Q:R660'>0 D
+40 ; .S RRX=$$SETFLD^VALM1($$ITEM^RMPREOU(R660,17),RRX,"ITEM")
+41 SET RRX=$$SETFLD^VALM1($$STATUS^RMPREOU(RMPRA,7),RRX,"STATUS")
+42 SET ^TMP($JOB,"RMPREO",LINE,0)=RRX
+43 SET ^TMP($JOB,"RMPREOEE",LINE,0)=RMPRA
End DoDot:1
+44 QUIT
+45 ;
+46 ;
SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ;set array
+1 IF '$DATA(@VALMAR@(LINE,0))
DO SET^VALM10(LINE,$JUSTIFY("",80))
+2 DO SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
+3 IF $GET(ON)]""!($GET(OFF)]"")
DO CNTRL^VALM10(LINE,COLUMN,$LENGTH(STRING),ON,OFF)
+4 QUIT
+5 ;
+6 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 ;NOT XUSCLEAN
+2 ;added by patch #62
+3 ;if transaction still exist for linking, print message and re-link
+4 IF $DATA(^TMP($JOB,"RMPRPCE"))
Begin DoDot:1
+5 SET RMQUIT=0
+6 WRITE @IOF
DO SMESS0^RMPRPCEL
DO CDIR^RMPRPCEL
End DoDot:1
if RMENTSUS="L"
GOTO EN
+7 KILL ^TMP($JOB,"RMPREO"),^TMP($JOB,"RMPREOEE")
+8 QUIT
+9 ;
EXPND ; -- expand code
+1 QUIT
