source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOL.m@ 1111

RMPREOL ;HINES/RVD  SUSPENSE PROCESSING/LINK TO 2319 ; 14-AUG-2001
 ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
 ;
 ; 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 WHO1'="" S RRX=$$SETFLD^VALM1(WHO1,RRX,"WHO")
 .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