RMPREO ;HINES/HNC - SUSPENSE PROCESSING; MARCH 10, 2005
;;3.0;PROSTHETICS;**45,55,83,182,191,212**;Feb 09, 1996;Build 5
;
;HNC #83, add free text ordering provider 3/10/05
;
;RMPR*3.0*182 Add Urgency flag to List Manager Suspense
; List and print template RPMR VIEW REQUEST
; for action 'View Request'
; Also, adds check that will insure variable
; RMPRSITE is undefined rather than test for
; array RMPR defined as a viable site exists
; in RMPRSITE.
;
;RMPR*3.0*191 Ensure array element RMPR("STA") is defined
; before further processing.
;
;RMPR*3.0*212 Resorts List by SUSPENSE DATE (RMPREO NEW)
; rather than by IEN (RMPREO).
;
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")
K ^TMP($J,"RMPREO NEW")
;ask station
I '$D(RMPRSITE)!'$D(RMPR("STA")) D DIV4^RMPRSIT Q:$D(X) ;RMPR*3.0*182, 191
I '$D(RMPRDFN) D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
D EN^VALM("RMPREO")
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)_") '!' = STAT" ;RMPR*3.0*182
D KVAR^VADPT
Q
;
INIT ; -- init variables and list array
K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
D HDR
N RMPRA,CDATE,LINE,X,RMPRSTAT ;RMPR*3*182
N SDATE ;RMPR*3*212
;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
.S VALMCNT=VALMCNT+1,LINE=VALMCNT
.S RRX=$$SETFLD^VALM1(LINE,RRX,"LINE")
.S RMPRSTAT="" I $P($G(^RMPR(668,RMPRA,8)),U,5)["STAT" S RMPRSTAT="!" ;RMPR*3*182
.S CDATE=$P(^RMPR(668,RMPRA,0),U,1),CDATE=$$DAT1^RMPRUTL1(CDATE)_RMPRSTAT ;RMPR*3*182
.S SDATE=$P(^RMPR(668,RMPRA,0),U) ;RMPR*3*212
.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,RMPRA)
.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
.S ^TMP($J,"RMPREO NEW",SDATE,LINE,RMPRA)=RRX ;resort array for RMPR*3*212
;resort RMPREO using RMPREO NEW;RMPR*3*212
I $D(^TMP($J,"RMPREO NEW")),$$SORT(SDATE) K ^TMP($J,"RMPREO NEW")
Q
;
SORT(SDATE) ;reorder RMPREO using RMPREO NEW;RMPR*3*212
N NL,SD,LINE,X,RMPRN K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
S SD="",NL=1 F S SD=$O(^TMP($J,"RMPREO NEW",SD),-1) Q:SD<1 D
.S LINE=0 F S LINE=$O(^TMP($J,"RMPREO NEW",SD,LINE)) Q:LINE<1 D
..S RMPRN=$O(^TMP($J,"RMPREO NEW",SD,LINE,0))
..S X=^TMP($J,"RMPREO NEW",SD,LINE,RMPRN),^TMP($J,"RMPREOEE",NL,0)=RMPRN
..S X=$$SETFLD^VALM1(NL,X,"LINE"),^TMP($J,"RMPREO",NL,0)=X,NL=NL+1
Q 1
;
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
K ^TMP($J,"RMPREO")
K ^TMP($J,"RMPREOEE")
K ^TMP($J,"RMPREO NEW")
K RMPRDFN
Q
;
EXPND ; -- expand code
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPREO 4407 printed Apr 09, 2024@21:35:49 Page 2
RMPREO ;HINES/HNC - SUSPENSE PROCESSING; MARCH 10, 2005
+1 ;;3.0;PROSTHETICS;**45,55,83,182,191,212**;Feb 09, 1996;Build 5
+2 ;
+3 ;HNC #83, add free text ordering provider 3/10/05
+4 ;
+5 ;RMPR*3.0*182 Add Urgency flag to List Manager Suspense
+6 ; List and print template RPMR VIEW REQUEST
+7 ; for action 'View Request'
+8 ; Also, adds check that will insure variable
+9 ; RMPRSITE is undefined rather than test for
+10 ; array RMPR defined as a viable site exists
+11 ; in RMPRSITE.
+12 ;
+13 ;RMPR*3.0*191 Ensure array element RMPR("STA") is defined
+14 ; before further processing.
+15 ;
+16 ;RMPR*3.0*212 Resorts List by SUSPENSE DATE (RMPREO NEW)
+17 ; rather than by IEN (RMPREO).
+18 ;
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 KILL ^TMP($JOB,"RMPREO NEW")
+7 ;ask station
+8 ;RMPR*3.0*182, 191
IF '$DATA(RMPRSITE)!'$DATA(RMPR("STA"))
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+9 IF '$DATA(RMPRDFN)
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
QUIT
+10 DO EN^VALM("RMPREO")
+11 QUIT
+12 ;
HDR ; -- header code
+1 NEW VA,VADM
+2 SET DFN=RMPRDFN
+3 DO DEM^VADPT
+4 ;S VALMHDR(1)="Suspense Processing"
+5 ;RMPR*3.0*182
SET VALMHDR(1)="Open/Pending/Closed Suspense for "_$$LOWER^VALM1(VADM(1))_" ("_$PIECE(VADM(2),U,2)_") '!' = STAT"
+6 DO KVAR^VADPT
+7 QUIT
+8 ;
INIT ; -- init variables and list array
+1 KILL ^TMP($JOB,"RMPREO"),^TMP($JOB,"RMPREOEE")
+2 DO HDR
+3 ;RMPR*3*182
NEW RMPRA,CDATE,LINE,X,RMPRSTAT
+4 ;RMPR*3*212
NEW SDATE
+5 ;start loop
+6 ;
+7 KILL ADATE,PDAY
+8 SET RMPRA=""
SET VALMCNT=0
SET RRX=""
+9 ;reverse order display
+10 FOR
SET RMPRA=$ORDER(^RMPR(668,"C",RMPRDFN,RMPRA),-1)
if RMPRA=""
QUIT
Begin DoDot:1
+11 IF $PIECE(^RMPR(668,RMPRA,0),U,10)="X"
QUIT
+12 SET VALMCNT=VALMCNT+1
SET LINE=VALMCNT
+13 SET RRX=$$SETFLD^VALM1(LINE,RRX,"LINE")
+14 ;RMPR*3*182
SET RMPRSTAT=""
IF $PIECE($GET(^RMPR(668,RMPRA,8)),U,5)["STAT"
SET RMPRSTAT="!"
+15 ;RMPR*3*182
SET CDATE=$PIECE(^RMPR(668,RMPRA,0),U,1)
SET CDATE=$$DAT1^RMPRUTL1(CDATE)_RMPRSTAT
+16 ;RMPR*3*212
SET SDATE=$PIECE(^RMPR(668,RMPRA,0),U)
+17 SET RRX=$$SETFLD^VALM1(CDATE,RRX,"DATE")
+18 SET WHO1=""
+19 IF $PIECE(^RMPR(668,RMPRA,0),U,11)'=""
SET WHO1=$$WHO^RMPREOU($PIECE(^RMPR(668,RMPRA,0),U,11),12,RMPRA)
+20 IF $PIECE($GET(^RMPR(668,RMPRA,"IFC1")),U,3)'=""
SET WHO1=$$WHO^RMPREOU("",12,RMPRA)
+21 ;
+22 SET RRX=$$SETFLD^VALM1(WHO1,RRX,"WHO")
+23 KILL WHO,WHO1
+24 ;type
+25 SET TYPE=$$TYPE^RMPREOU(RMPRA,8)
+26 SET RRX=$$SETFLD^VALM1(TYPE,RRX,"TYPE")
+27 ;display description if manual
+28 ;
+29 SET RRX=$$SETFLD^VALM1($$DES^RMPREOU(RMPRA,22),RRX,"DES")
+30 ;init activation date
+31 SET ADATE=""
SET PDAY=""
SET WRKDAY=""
+32 SET ADATE=$PIECE(^RMPR(668,RMPRA,0),U,9)
+33 IF ADATE'=""
SET (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA)
+34 IF ADATE=""
SET (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA)
+35 SET RRX=$$SETFLD^VALM1($$DAT1^RMPRUTL1(ADATE),RRX,"INITIAL ACTION DATE")
+36 IF ADATE'=""
SET CDAY=$$PDAY^RMPREOU(RMPRA)
IF CDAY>7
SET PDAY="*"_WRKDAY
+37 IF ADATE=""&(WRKDAY>5)
SET PDAY="@"_WRKDAY
+38 SET RRX=$$SETFLD^VALM1(PDAY,RRX,"PDAY")
+39 KILL ADATE,PDAY,WRKDAY,CDAY
+40 ;S R660=""
+41 ;F S R660=$O(^RMPR(668,RMPRA,6,"B",R660)) Q:R660'>0 D
+42 ; .S RRX=$$SETFLD^VALM1($$ITEM^RMPREOU(R660,17),RRX,"ITEM")
+43 SET RRX=$$SETFLD^VALM1($$STATUS^RMPREOU(RMPRA,7),RRX,"STATUS")
+44 SET ^TMP($JOB,"RMPREO",LINE,0)=RRX
+45 SET ^TMP($JOB,"RMPREOEE",LINE,0)=RMPRA
+46 ;resort array for RMPR*3*212
SET ^TMP($JOB,"RMPREO NEW",SDATE,LINE,RMPRA)=RRX
End DoDot:1
+47 ;resort RMPREO using RMPREO NEW;RMPR*3*212
+48 IF $DATA(^TMP($JOB,"RMPREO NEW"))
IF $$SORT(SDATE)
KILL ^TMP($JOB,"RMPREO NEW")
+49 QUIT
+50 ;
SORT(SDATE) ;reorder RMPREO using RMPREO NEW;RMPR*3*212
+1 NEW NL,SD,LINE,X,RMPRN
KILL ^TMP($JOB,"RMPREO"),^TMP($JOB,"RMPREOEE")
+2 SET SD=""
SET NL=1
FOR
SET SD=$ORDER(^TMP($JOB,"RMPREO NEW",SD),-1)
if SD<1
QUIT
Begin DoDot:1
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP($JOB,"RMPREO NEW",SD,LINE))
if LINE<1
QUIT
Begin DoDot:2
+4 SET RMPRN=$ORDER(^TMP($JOB,"RMPREO NEW",SD,LINE,0))
+5 SET X=^TMP($JOB,"RMPREO NEW",SD,LINE,RMPRN)
SET ^TMP($JOB,"RMPREOEE",NL,0)=RMPRN
+6 SET X=$$SETFLD^VALM1(NL,X,"LINE")
SET ^TMP($JOB,"RMPREO",NL,0)=X
SET NL=NL+1
End DoDot:2
End DoDot:1
+7 QUIT 1
+8 ;
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 KILL ^TMP($JOB,"RMPREO")
+3 KILL ^TMP($JOB,"RMPREOEE")
+4 KILL ^TMP($JOB,"RMPREO NEW")
+5 KILL RMPRDFN
+6 QUIT
+7 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
