RMPRPCEC ;HINCIO/RVD-PCE CREATE 660 & 668 ;07/17/2001
;;3.0;PROSTHETICS;**62**;Feb 09, 1996
;RVD patch #62 - for PCE interface.
;
;RMI60 - IEN of file #660
;If error occured, return value = 1
ASK68(RMI60) ;ask for suspense entry.
D NEWVAR
S RMERR=0
S RMDFN=$P(^RMPR(660,RMI60,0),U,2)
ASK S RMI68=$$G68^RMPRPCEG(RMDFN)
I RMI68>0 G UP60
I RMI68="^" W !!,"*** NO LINK TO SUSPENSE RECORD!!!",! H 3 G EXIT
W !!,"*** NO SUSPENSE RECORD SELECTED !!!",!
K DIR
S DIR("A")="Want to CREATE this entry without suspense"
S DIR("B")="Y",DIR(0)="Y"
D ^DIR K DIR
I Y=0 G ASK
;I (Y="^")!(Y="E") S RMERR=1 G EXIT
;G EXIT
;
UP60 ;call PCE API to create suspense entry in #660
S RMCHK=$$UP60^RMPRPCE1(RMI60,RMI68)
I $G(RMCHK) S RMERR=1 H 3 G EXIT
;
UP68 ;call PCE API to create 2319 entry in #668
;S RMI68=$P($G(^RMPR(660,RMI60,10)),U,1)
;G:'$G(RMI68) PO2319
S RMCHK=$$UP68^RMPRPCE1(RMI60,RMI68)
I $G(RMCHK) S RMERR=1 H 3 G EXIT
;
EXIT ;EXIT
Q RMERR
;
NEWVAR ;
N RMI68,DIR,DIR,DIK,Y,X,RMCHK,RMDFN,RMIE60,RMIE68
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPCEC 1063 printed Dec 13, 2024@02:35:43 Page 2
RMPRPCEC ;HINCIO/RVD-PCE CREATE 660 & 668 ;07/17/2001
+1 ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
+2 ;RVD patch #62 - for PCE interface.
+3 ;
+4 ;RMI60 - IEN of file #660
+5 ;If error occured, return value = 1
ASK68(RMI60) ;ask for suspense entry.
+1 DO NEWVAR
+2 SET RMERR=0
+3 SET RMDFN=$PIECE(^RMPR(660,RMI60,0),U,2)
ASK SET RMI68=$$G68^RMPRPCEG(RMDFN)
+1 IF RMI68>0
GOTO UP60
+2 IF RMI68="^"
WRITE !!,"*** NO LINK TO SUSPENSE RECORD!!!",!
HANG 3
GOTO EXIT
+3 WRITE !!,"*** NO SUSPENSE RECORD SELECTED !!!",!
+4 KILL DIR
+5 SET DIR("A")="Want to CREATE this entry without suspense"
+6 SET DIR("B")="Y"
SET DIR(0)="Y"
+7 DO ^DIR
KILL DIR
+8 IF Y=0
GOTO ASK
+9 ;I (Y="^")!(Y="E") S RMERR=1 G EXIT
+10 ;G EXIT
+11 ;
UP60 ;call PCE API to create suspense entry in #660
+1 SET RMCHK=$$UP60^RMPRPCE1(RMI60,RMI68)
+2 IF $GET(RMCHK)
SET RMERR=1
HANG 3
GOTO EXIT
+3 ;
UP68 ;call PCE API to create 2319 entry in #668
+1 ;S RMI68=$P($G(^RMPR(660,RMI60,10)),U,1)
+2 ;G:'$G(RMI68) PO2319
+3 SET RMCHK=$$UP68^RMPRPCE1(RMI60,RMI68)
+4 IF $GET(RMCHK)
SET RMERR=1
HANG 3
GOTO EXIT
+5 ;
EXIT ;EXIT
+1 QUIT RMERR
+2 ;
NEWVAR ;
+1 NEW RMI68,DIR,DIR,DIK,Y,X,RMCHK,RMDFN,RMIE60,RMIE68
+2 QUIT
