DVBCLURN ;ALB ISC/GTS - PRINT ROUTINE FOR MTLU LIST SEARCHES ;
;;2.7;AMIE;;Apr 10, 1995
;** ^TMP AND XTLKH ARE PASSED IN AND SHOULD NOT BE KILLED
;
;** VARIABLE DESCRIPTIONS
;** XTLKH - Entry number
;** ^TMP Global - Sort array of entries found in file ^DIC(31,
;** DVBAREF - Diagnostic code
;** DVBAREF0 - Zero node of current entry in ^DIC(31,
;** DVBAREF1 - One node of current entry in ^DIC(31,
;** DVBATEST - Node in TMP array following one printed
;
WLINE ;** DISPLAY CODE AND TEXT FOR DIAGNOSIS
S DVBAREF0="^DIC(31,"_Y_",0)"
S DVBAREF1="^DIC(31,"_Y_",1)"
I '$D(@(DVBAREF0))!('$D(@(DVBAREF1))) DO
.W:XTLKH !,$J(XTLKH,4),": Bad 'ADVB' X-REF ("_Y_") on File 31...Notify IRM "
Q:'$D(@(DVBAREF0))!('$D(@(DVBAREF1))) ;** QUIT if a bad pointer exists
S DVBAREF=$P(@(DVBAREF0),"^",3) ;** Indirection to 0 node, file 31
W:((XTLKH>1)&(XTLKH#5=1)) !!
W:XTLKH !,$J(XTLKH,4),": " ;** Write Entry number
;**
;** Write Detailed Desc. if exists, else write General Desc.
;** Use indirection to the 0 and 1 nodes, file 31 (DVBAREF0, DVBAREF1)
;**
W $S($D(@(DVBAREF1)):@(DVBAREF1),1:$P(@(DVBAREF0),"^",1))
W " ("_DVBAREF_")"
I XTLKH#5'>0 DO ;** Output number remaining, if any
.S DVBATEST=$O(^TMP("XTLKHITS",$J,XTLKH))
.I +DVBATEST>0 DO
..W !!,"Selections "
..W XTLKH+1
..W " through "_^TMP("XTLKHITS",$J)_" follow."
K DVBATEST,DVBAREF,DVBAREF0,DVBAREF1
Q
;
ORPHAN ;the display for the orphan MTLU look up
W:XTLKMULT !,$J(XTLKH,4),": "
W $P(@(XTLKREF0),"^",1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCLURN 1575 printed Dec 13, 2024@01:44:48 Page 2
DVBCLURN ;ALB ISC/GTS - PRINT ROUTINE FOR MTLU LIST SEARCHES ;
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;** ^TMP AND XTLKH ARE PASSED IN AND SHOULD NOT BE KILLED
+3 ;
+4 ;** VARIABLE DESCRIPTIONS
+5 ;** XTLKH - Entry number
+6 ;** ^TMP Global - Sort array of entries found in file ^DIC(31,
+7 ;** DVBAREF - Diagnostic code
+8 ;** DVBAREF0 - Zero node of current entry in ^DIC(31,
+9 ;** DVBAREF1 - One node of current entry in ^DIC(31,
+10 ;** DVBATEST - Node in TMP array following one printed
+11 ;
WLINE ;** DISPLAY CODE AND TEXT FOR DIAGNOSIS
+1 SET DVBAREF0="^DIC(31,"_Y_",0)"
+2 SET DVBAREF1="^DIC(31,"_Y_",1)"
+3 IF '$DATA(@(DVBAREF0))!('$DATA(@(DVBAREF1)))
Begin DoDot:1
+4 if XTLKH
WRITE !,$JUSTIFY(XTLKH,4),": Bad 'ADVB' X-REF ("_Y_") on File 31...Notify IRM "
End DoDot:1
+5 ;** QUIT if a bad pointer exists
if '$DATA(@(DVBAREF0))!('$DATA(@(DVBAREF1)))
QUIT
+6 ;** Indirection to 0 node, file 31
SET DVBAREF=$PIECE(@(DVBAREF0),"^",3)
+7 if ((XTLKH>1)&(XTLKH#5=1))
WRITE !!
+8 ;** Write Entry number
if XTLKH
WRITE !,$JUSTIFY(XTLKH,4),": "
+9 ;**
+10 ;** Write Detailed Desc. if exists, else write General Desc.
+11 ;** Use indirection to the 0 and 1 nodes, file 31 (DVBAREF0, DVBAREF1)
+12 ;**
+13 WRITE $SELECT($DATA(@(DVBAREF1)):@(DVBAREF1),1:$PIECE(@(DVBAREF0),"^",1))
+14 WRITE " ("_DVBAREF_")"
+15 ;** Output number remaining, if any
IF XTLKH#5'>0
Begin DoDot:1
+16 SET DVBATEST=$ORDER(^TMP("XTLKHITS",$JOB,XTLKH))
+17 IF +DVBATEST>0
Begin DoDot:2
+18 WRITE !!,"Selections "
+19 WRITE XTLKH+1
+20 WRITE " through "_^TMP("XTLKHITS",$JOB)_" follow."
End DoDot:2
End DoDot:1
+21 KILL DVBATEST,DVBAREF,DVBAREF0,DVBAREF1
+22 QUIT
+23 ;
ORPHAN ;the display for the orphan MTLU look up
+1 if XTLKMULT
WRITE !,$JUSTIFY(XTLKH,4),": "
+2 WRITE $PIECE(@(XTLKREF0),"^",1)
+3 QUIT
