- 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 Feb 19, 2025@00:00:52 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 ;