ENAR2 ;(WASH ISC)/JED/DH-Archive Module ;3-9-89
;;7.0;ENGINEERING;;Aug 17, 1993
;EXPANSION OF ENAR1, CALLED BY ENAR1
ID ;DISPLAY ID INFO
I '$D(ENDA),'($D(^ENAR(ENGBL,-1))#10) D ID1 Q
I '$D(ENDA) S ENID=^ENAR(ENGBL,-1) S:$D(@ENID)=1 ENDA=+$P(ENID,",",4) I $D(@ENID)'=1 D ID1 Q
I $E(IOST)'="P" S (DA,DJDN,W(1))=ENDA,(DJNM,DJSC)="ENAR",DJDIS=1 D ^ENJPARAM Q:'$D(DJRJ) D ^ENJDPL,^ENJC2
I $E(IOST)="P" S DIC="^ENG(6919,",DA=ENDA D EN^DIQ K DIC,DA Q
K DA,DJCL,DJCP,DJDD,DJDIS,DJDN,DJDPL,DJEOP,DJF,DJFF,DJHIN,DJJ,DJK,DJKEY,DJRJ,DJSC,DJST,DJT,W,V Q
ID1 W !,"Insufficient data to display the ID information." Q
C ;CONFIRM ID DISPLAY
D ID W !!!!,"Please confirm, is this the expected archive record" S %=1 D YN^DICN Q:%=1
I %=0 W !,"The existing system archive global has the following ID information",!! G C
S ENERR="ARCHIVE RECORD NOT CONFIRMED"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENAR2 867 printed Dec 13, 2024@01:51:30 Page 2
ENAR2 ;(WASH ISC)/JED/DH-Archive Module ;3-9-89
+1 ;;7.0;ENGINEERING;;Aug 17, 1993
+2 ;EXPANSION OF ENAR1, CALLED BY ENAR1
ID ;DISPLAY ID INFO
+1 IF '$DATA(ENDA)
IF '($DATA(^ENAR(ENGBL,-1))#10)
DO ID1
QUIT
+2 IF '$DATA(ENDA)
SET ENID=^ENAR(ENGBL,-1)
if $DATA(@ENID)=1
SET ENDA=+$PIECE(ENID,",",4)
IF $DATA(@ENID)'=1
DO ID1
QUIT
+3 IF $EXTRACT(IOST)'="P"
SET (DA,DJDN,W(1))=ENDA
SET (DJNM,DJSC)="ENAR"
SET DJDIS=1
DO ^ENJPARAM
if '$DATA(DJRJ)
QUIT
DO ^ENJDPL
DO ^ENJC2
+4 IF $EXTRACT(IOST)="P"
SET DIC="^ENG(6919,"
SET DA=ENDA
DO EN^DIQ
KILL DIC,DA
QUIT
+5 KILL DA,DJCL,DJCP,DJDD,DJDIS,DJDN,DJDPL,DJEOP,DJF,DJFF,DJHIN,DJJ,DJK,DJKEY,DJRJ,DJSC,DJST,DJT,W,V
QUIT
ID1 WRITE !,"Insufficient data to display the ID information."
QUIT
C ;CONFIRM ID DISPLAY
+1 DO ID
WRITE !!!!,"Please confirm, is this the expected archive record"
SET %=1
DO YN^DICN
if %=1
QUIT
+2 IF %=0
WRITE !,"The existing system archive global has the following ID information",!!
GOTO C
+3 SET ENERR="ARCHIVE RECORD NOT CONFIRMED"
+4 QUIT
