MCARDHLP.m

MCARDHLP ;WISC/DCB-HELP FOR SCREEN INPUT ;8/27/96  10:06

 ;;2.3;Medicine;;09/13/1996

 Q

START ;

 N SPACE,X,Y S MCARGDA=DJDN

 N VAL,MCERR,FLAG,TMP,XHOLD

 N SPACE S SPACE="" S $P(SPACE," ",80)=""

 I $D(MCDID) S DX=1,DY=1 X XY W SPACE

 Q:'$D(DJJ(+V))

 S @$P(DJJ(V),U,2) X XY

 I $D(MCHELPSW),('$D(MCHELPS2)) D FUNC^MCARDNQ2 K MCMASS D SKIP Q

 I $D(MCDID),$D(MCHELPSW),'$D(MCHELPS2) Q

 I (DJ4["200")!(DJ4["690") D FUNC Q

 S VAL=$P(DJ0,U,2)

 I VAL["F" G FUNC

 I VAL["S" D SETH(DJDD,DJAT,DJ0) D SKIP Q

 I DJ4["M" D MULT(DJDD,DJAT,DJDN,.FLAG)

 I VAL["P" D POINTER(DJDD,DJAT) D FUNC:$D(MCERR),SKIP Q

 I DJ4["M",VAL["D" D  Q  ; New line & dot block DAD 7-23-96

 . N %DT,DJAT,DJDD,DJX,MCMASS,X

 . S DJDD=+$P(DJ0,U,2),DJAT=.01

 . S X=$P($P(DJ0,U,5)," D ^%DT") S:X="" X="S %DT=""E""" X X

 . I $D(DJCP) X DJCP X XY W DJLIN

 . D HELP^MCARDNQ,FUNC

 . Q

 I DJ4["M",$TR(VAL,"aeAIM")=+VAL D  Q  ; New line & dot block DAD 8-14-96

 . N DJAT,DJDD

 . S DJDD=+$P(DJ0,U,2),DJAT=.01

 . I $D(DJCP) X DJCP X XY W DJLIN

 . D FUNC

 . Q

FUNC ;

 D NUMBER(DJDD,DJAT)

 I $G(MCERR) D FUNC^MCARDNQ2

SKIP ;

 S MCDID=1

 S @$P(DJJ(V),U,2) X XY Q

POINTER(XFILE,FLD) ;

 N LINE,PTER,SUB,GL,XFLD,HOLD S HOLD=XFILE

 S LINE=$G(^DD(XFILE,FLD,0)) I LINE="" S MCERR=0 Q

 S GL=$P(LINE,U,3),LINE=$P(LINE,U,2)

 I GL'="" S PTER=+$P(LINE,"P",2)

 E  S XFILE=+LINE,XFLD=.01,PTER=+$P($P($G(^DD(XFILE,XFLD,0)),U,2),"P",2)

 I +PTER=0 S MCERR=0 Q

 I PTER=200 S MCERR=0 Q

 D POINTERH(XFILE,PTER,FLD,HOLD)

 Q

POINTERH(XFILE,MFILE,FLD,HOLD) ;

 N DIC,TMP,REC,LOOP,TOTAL,LEN,GLOBAL,Y,SETLOC

 N FIELDS,TYPE,EXC,TEMP,ERROR,X,XREF,SWITCH

 D RTNELM^MCDBELM(MFILE,1,".01","","","E","",.TEMP,.ERROR)

 S GLOBAL=TEMP("DIC"),XREF=GLOBAL_"""B"")"

 S GLOBAL=TEMP("GLO")

 S REC=+$P($G(@GLOBAL@(0)),U,4) I REC>200!(REC<1) S MCERR=1 Q

 S SETLOC=$$SCRN(HOLD,FLD),LOOP=0,D0=DJDN,HOLD=""

 W !

 F  S HOLD=$O(@XREF@(HOLD)) Q:HOLD=""  D

 .S Y=$O(@XREF@(HOLD,0))

 .S TEP=$G(@GLOBAL@(Y,0)),REC=Y X SETLOC

 .I $T D

 ..S $P(TEMP(1),U,2)=Y D GETDATA^MCDBSAVE(.TEMP,.ERROR)

 ..S XHOLD=$D(XHOLD(REC)),LOOP=LOOP+1

 ..S TMP(TEMP("FLD",.01))=XHOLD S SWITCH=XHOLD

 I (LOOP<1) S MCERR=1 Q

 I (LOOP>70) D:SWITCH'=0 ADJUST

 D HEADER("{Current choices}")

 D POINTER2(LOOP)

 Q

ADJUST ;

 N %X,%Y,HOLD,TOTAL,XTEMP S XTEMP(1)="CURENTLY IN LIST",TOTAL=1

 F HOLD=1:1:LOOP D

 .I $D(TMP(HOLD,0)) S TOTAL=TOTAL+1,XTEMP(TOTAL)=TMP(HOLD,0)

 S LOOP=TOTAL K TMP

 S %X="XTEMP(",%Y="TMP(" D %XY^%RCR

 Q

POINTER2(TOTAL) ;Help display for pointers

 N MAX,COL,SP,VAL,TYPE S VAL=""

 I TOTAL=0 S MCERR=1 Q

 S SP=" ",$P(SP," ",80)="",CT=0,COL=(TOTAL\7)

 S:(TOTAL/7)'=(TOTAL\7) COL=COL+1

 S MAX=80\COL,MLEN=MAX-2,COL=COL-1

 I $D(DJCP) X DJCP X XY W DJLIN

 F LOOP=1:1:TOTAL S VAL=$O(TMP(VAL)) Q:VAL=""  D

 .S TYPE=TMP(VAL)

 .I CT>COL S CT=0 W !

 .I $G(VAL)'="" D

 ..S CT=CT+1

 ..W $S(TYPE:$G(DJHIN),1:"")_$E($E(VAL,1,MLEN)_SP,1,MAX)_$S(TYPE:$G(DJLIN),1:"")

 Q

SETH(FILE,FIELD,TEMP) ;

 N DIC,LOOP,ITEMS,TMP,LOP,MAX,MLEN1,MLEN2,TOTAL

 I +$P(TEMP,U,2)'=0 S FILE=+$P(TEMP,U,2),FIELD=.01,TEMP=""

 S:$P($G(TEMP),U,3)="" TEMP=$G(^DD(FILE,FIELD,0))

 S TMP=$P(TEMP,U,3),MLEN1=0,MLEN2=0

 S DIC("S")=$$SCRN(FILE,FIELD),LOOP(0)=0,ITEMS=""

 Q:TMP=""

 F LOOP=1:1:$L(TMP,";") S MAX=$P(TMP,";",LOOP) Q:MAX=""  D

 .I $G(DIC("S"))]"" S Y=$P(MAX,":") I Y]"" X DIC("S") Q:'$T

 .S LOOP(0)=LOOP(0)+1,ITEMS=ITEMS_MAX_";"

 .S LEN1=$L($P(MAX,":",1)) S:LEN1>MLEN1 MLEN1=LEN1

 .S LEN2=$L($P(MAX,":",2)) S:LEN2>MLEN2 MLEN2=LEN2

 S TOTAL=LOOP(0) D SET2(ITEMS,TOTAL,MLEN1,MLEN2)

 Q

SET2(TMP,TOTAL,MLEN1,MLEN2) ;

 N MAX,COL,CT,LOOP,F1,F2,SP,Y

 S SP="",$P(SP," ",80)="",MLEN=MLEN1+3+MLEN2+2,CT=0

 S COL=(TOTAL\7) S:(TOTAL/7)'=(TOTAL\7) COL=COL+1

 S MAX=80\COL,MAX=MAX-2 S:MAX<MLEN MLEN=MAX

 S COL=COL-1

 S:COL=3&(TOTAL<8) COL=1 I $D(DJCP) X DJCP X XY W DJLIN

 F LOOP=1:1:TOTAL D

 .S TEMP=$P(TMP,";",LOOP),F1=$P(TEMP,":",1),F2=$P(TEMP,":",2)

 .S F1=$E(F1_SP,1,MLEN1),F2=$E(F2_SP,1,MLEN2)

 .I CT>COL S CT=0 W !

 .W $G(DJHIN),F1,$G(DJLIN)," - ",F2,"  "

 .S CT=CT+1

 D HEADER("{Help prompt for Set of Codes}")

 Q

NUMBER(FILE,FIELD) ;

 N VAL

 S VAL=$G(^DD(FILE,FIELD,3)) I VAL="" S MCERR=1 Q

 D HEADER("{Help prompt}")

 I $D(DJCP) X DJCP X XY W DJLIN

 W !!,VAL

 Q

MULT(FILE,FIELD,XREC,FLAG) ;

 N FIELDS,REC,EXC,DATA,TYPE,USER,TEMP,ERROR,LOOP,TOTAL,GLO,LEVEL

 S LEVEL=1,FIELDS=FIELD,REC=""

 D MAIN(FILE,.FIELDS,.LEVEL)

 I LEVEL>1 F LOOP=1:1:LEVEL S REC=REC_^TMP($J,"DJST",LOOP,"DA")_U

 E  S REC=XREC_U,FIELDS=FIELD_U

 S REC=REC_1,FIELDS=FIELDS_".01"

 ;; ***ORIGINAL*** ;; S:$D(^DD(FILE,0,"UP")) FILE=^DD(FILE,0,"UP")

 F  S FILE(0)=$G(^DD(FILE,0,"UP")) Q:FILE(0)'>0  S FILE=FILE(0) ;DAD81496

 D RTNELM^MCDBELM(FILE,REC,FIELDS,"","","E","",.TEMP,.ERROR)

 S GLO=TEMP("GLO")

 F LOOP=0:0 S LOOP=+$O(@GLO@(LOOP)) Q:LOOP=0  D

 .S REC=+$P($G(@GLO@(LOOP,0)),U,1),XHOLD(REC)=""

 Q

MAIN(FILE,FIELDS,LEVEL) ;

 N HOLD,NAME

 S HOLD=$G(^DD(FILE,0,"UP"))

 I HOLD="" S FIELDS=$$REORDER(FIELDS,LEVEL) Q

 S NAME=$O(^DD(FILE,0,"NM","")),LEVEL=LEVEL+1

 S FIELDS=$G(FIELDS)_U_+$O(^DD(HOLD,"B",NAME,0))

 D MAIN(HOLD,.FIELDS,LEVEL)

 Q

REORDER(FIELDS,LEVEL) ;

 N LOOP,HOLD S HOLD="" I LEVEL<2 Q ""

 F LOOP=LEVEL:-1:1 D

 .S HOLD=HOLD_$P(FIELDS,U,LOOP)_U

 Q HOLD

HEADER(MCHELP) ;

 N SPACE,TEMP,TMP S SPACE="",$P(SPACE," ",80)=" "

 S DX=1,DY=1 X XY

 S TMP=40-$L(MCHELP)

 S TEMP=$E(SPACE,1,TMP)_MCHELP

 W DJHIN,"*** Commands: ^C ",$S($D(DJTOGGLE):"or KP1 ",1:""),"***",?40,TEMP,DJLIN

 Q

SCRN(SFILE,SFLD) ;

 N SCREEN

 I $G(^DD(SFILE,SFLD,12.1))'="" D SCSET

 I '$D(SCREEN) D

 .S SFILE=+$P(^DD(SFILE,SFLD,0),U,2),SFLD=.01

 .I 'SFILE?1N.N1".".N S SFILE=+$P(SFILE,"P",2)

 .I $G(^DD(SFILE,SFLD,12.1))'="" D SCSET

 Q $S($D(SCREEN):SCREEN,1:"I 1")

SCSET ;

 I ^DD(SFILE,SFLD,12.1)["S DIC(""S"")" X ^(12.1) S SCREEN=DIC("S") K DIC("S") Q

 S SCREEN=^DD(SFILE,SFLD,12.1) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MCARDHLP   5843     printed  Feb 18, 2025@23:39:03                                                                                                                                                                                                    Page 2

MCARDHLP  ;WISC/DCB-HELP FOR SCREEN INPUT ;8/27/96  10:06

 +1       ;;2.3;Medicine;;09/13/1996

 +2        QUIT 

START     ;

 +1        NEW SPACE,X,Y

           SET MCARGDA=DJDN

 +2        NEW VAL,MCERR,FLAG,TMP,XHOLD

 +3        NEW SPACE

           SET SPACE=""

           SET $PIECE(SPACE," ",80)=""

 +4        IF $DATA(MCDID)

               SET DX=1

               SET DY=1

               XECUTE XY

               WRITE SPACE

 +5        if '$DATA(DJJ(+V))

               QUIT 

 +6        SET @$PIECE(DJJ(V),U,2)

           XECUTE XY

 +7        IF $DATA(MCHELPSW)

               IF ('$DATA(MCHELPS2))

                   DO FUNC^MCARDNQ2

                   KILL MCMASS

                   DO SKIP

                   QUIT 

 +8        IF $DATA(MCDID)

               IF $DATA(MCHELPSW)

                   IF '$DATA(MCHELPS2)

                       QUIT 

 +9        IF (DJ4["200")!(DJ4["690")

               DO FUNC

               QUIT 

 +10       SET VAL=$PIECE(DJ0,U,2)

 +11       IF VAL["F"

               GOTO FUNC

 +12       IF VAL["S"

               DO SETH(DJDD,DJAT,DJ0)

               DO SKIP

               QUIT 

 +13       IF DJ4["M"

               DO MULT(DJDD,DJAT,DJDN,.FLAG)

 +14       IF VAL["P"

               DO POINTER(DJDD,DJAT)

               if $DATA(MCERR)

                   DO FUNC

               DO SKIP

               QUIT 

 +15      ; New line & dot block DAD 7-23-96

           IF DJ4["M"

               IF VAL["D"

                   Begin DoDot:1

 +16                   NEW %DT,DJAT,DJDD,DJX,MCMASS,X

 +17                   SET DJDD=+$PIECE(DJ0,U,2)

                       SET DJAT=.01

 +18                   SET X=$PIECE($PIECE(DJ0,U,5)," D ^%DT")

                       if X=""

                           SET X="S %DT=""E"""

                       XECUTE X

 +19                   IF $DATA(DJCP)

                           XECUTE DJCP

                           XECUTE XY

                           WRITE DJLIN

 +20                   DO HELP^MCARDNQ

                       DO FUNC

 +21                   QUIT 

                   End DoDot:1

                   QUIT 

 +22      ; New line & dot block DAD 8-14-96

           IF DJ4["M"

               IF $TRANSLATE(VAL,"aeAIM")=+VAL

                   Begin DoDot:1

 +23                   NEW DJAT,DJDD

 +24                   SET DJDD=+$PIECE(DJ0,U,2)

                       SET DJAT=.01

 +25                   IF $DATA(DJCP)

                           XECUTE DJCP

                           XECUTE XY

                           WRITE DJLIN

 +26                   DO FUNC

 +27                   QUIT 

                   End DoDot:1

                   QUIT 

FUNC      ;

 +1        DO NUMBER(DJDD,DJAT)

 +2        IF $GET(MCERR)

               DO FUNC^MCARDNQ2

SKIP      ;

 +1        SET MCDID=1

 +2        SET @$PIECE(DJJ(V),U,2)

           XECUTE XY

           QUIT 

POINTER(XFILE,FLD) ;

 +1        NEW LINE,PTER,SUB,GL,XFLD,HOLD

           SET HOLD=XFILE

 +2        SET LINE=$GET(^DD(XFILE,FLD,0))

           IF LINE=""

               SET MCERR=0

               QUIT 

 +3        SET GL=$PIECE(LINE,U,3)

           SET LINE=$PIECE(LINE,U,2)

 +4        IF GL'=""

               SET PTER=+$PIECE(LINE,"P",2)

 +5       IF '$TEST

               SET XFILE=+LINE

               SET XFLD=.01

               SET PTER=+$PIECE($PIECE($GET(^DD(XFILE,XFLD,0)),U,2),"P",2)

 +6        IF +PTER=0

               SET MCERR=0

               QUIT 

 +7        IF PTER=200

               SET MCERR=0

               QUIT 

 +8        DO POINTERH(XFILE,PTER,FLD,HOLD)

 +9        QUIT 

POINTERH(XFILE,MFILE,FLD,HOLD) ;

 +1        NEW DIC,TMP,REC,LOOP,TOTAL,LEN,GLOBAL,Y,SETLOC

 +2        NEW FIELDS,TYPE,EXC,TEMP,ERROR,X,XREF,SWITCH

 +3        DO RTNELM^MCDBELM(MFILE,1,".01","","","E","",.TEMP,.ERROR)

 +4        SET GLOBAL=TEMP("DIC")

           SET XREF=GLOBAL_"""B"")"

 +5        SET GLOBAL=TEMP("GLO")

 +6        SET REC=+$PIECE($GET(@GLOBAL@(0)),U,4)

           IF REC>200!(REC<1)

               SET MCERR=1

               QUIT 

 +7        SET SETLOC=$$SCRN(HOLD,FLD)

           SET LOOP=0

           SET D0=DJDN

           SET HOLD=""

 +8        WRITE !

 +9        FOR 

               SET HOLD=$ORDER(@XREF@(HOLD))

               if HOLD=""

                   QUIT 

               Begin DoDot:1

 +10               SET Y=$ORDER(@XREF@(HOLD,0))

 +11               SET TEP=$GET(@GLOBAL@(Y,0))

                   SET REC=Y

                   XECUTE SETLOC

 +12               IF $TEST

                       Begin DoDot:2

 +13                       SET $PIECE(TEMP(1),U,2)=Y

                           DO GETDATA^MCDBSAVE(.TEMP,.ERROR)

 +14                       SET XHOLD=$DATA(XHOLD(REC))

                           SET LOOP=LOOP+1

 +15                       SET TMP(TEMP("FLD",.01))=XHOLD

                           SET SWITCH=XHOLD

                       End DoDot:2

               End DoDot:1

 +16       IF (LOOP<1)

               SET MCERR=1

               QUIT 

 +17       IF (LOOP>70)

               if SWITCH'=0

                   DO ADJUST

 +18       DO HEADER("{Current choices}")

 +19       DO POINTER2(LOOP)

 +20       QUIT 

ADJUST    ;

 +1        NEW %X,%Y,HOLD,TOTAL,XTEMP

           SET XTEMP(1)="CURENTLY IN LIST"

           SET TOTAL=1

 +2        FOR HOLD=1:1:LOOP

               Begin DoDot:1

 +3                IF $DATA(TMP(HOLD,0))

                       SET TOTAL=TOTAL+1

                       SET XTEMP(TOTAL)=TMP(HOLD,0)

               End DoDot:1

 +4        SET LOOP=TOTAL

           KILL TMP

 +5        SET %X="XTEMP("

           SET %Y="TMP("

           DO %XY^%RCR

 +6        QUIT 

POINTER2(TOTAL) ;Help display for pointers

 +1        NEW MAX,COL,SP,VAL,TYPE

           SET VAL=""

 +2        IF TOTAL=0

               SET MCERR=1

               QUIT 

 +3        SET SP=" "

           SET $PIECE(SP," ",80)=""

           SET CT=0

           SET COL=(TOTAL\7)

 +4        if (TOTAL/7)'=(TOTAL\7)

               SET COL=COL+1

 +5        SET MAX=80\COL

           SET MLEN=MAX-2

           SET COL=COL-1

 +6        IF $DATA(DJCP)

               XECUTE DJCP

               XECUTE XY

               WRITE DJLIN

 +7        FOR LOOP=1:1:TOTAL

               SET VAL=$ORDER(TMP(VAL))

               if VAL=""

                   QUIT 

               Begin DoDot:1

 +8                SET TYPE=TMP(VAL)

 +9                IF CT>COL

                       SET CT=0

                       WRITE !

 +10               IF $GET(VAL)'=""

                       Begin DoDot:2

 +11                       SET CT=CT+1

 +12                       WRITE $SELECT(TYPE:$GET(DJHIN),1:"")_$EXTRACT($EXTRACT(VAL,1,MLEN)_SP,1,MAX)_$SELECT(TYPE:$GET(DJLIN),1:"")

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

SETH(FILE,FIELD,TEMP) ;

 +1        NEW DIC,LOOP,ITEMS,TMP,LOP,MAX,MLEN1,MLEN2,TOTAL

 +2        IF +$PIECE(TEMP,U,2)'=0

               SET FILE=+$PIECE(TEMP,U,2)

               SET FIELD=.01

               SET TEMP=""

 +3        if $PIECE($GET(TEMP),U,3)=""

               SET TEMP=$GET(^DD(FILE,FIELD,0))

 +4        SET TMP=$PIECE(TEMP,U,3)

           SET MLEN1=0

           SET MLEN2=0

 +5        SET DIC("S")=$$SCRN(FILE,FIELD)

           SET LOOP(0)=0

           SET ITEMS=""

 +6        if TMP=""

               QUIT 

 +7        FOR LOOP=1:1:$LENGTH(TMP,";")

               SET MAX=$PIECE(TMP,";",LOOP)

               if MAX=""

                   QUIT 

               Begin DoDot:1

 +8                IF $GET(DIC("S"))]""

                       SET Y=$PIECE(MAX,":")

                       IF Y]""

                           XECUTE DIC("S")

                           if '$TEST

                               QUIT 

 +9                SET LOOP(0)=LOOP(0)+1

                   SET ITEMS=ITEMS_MAX_";"

 +10               SET LEN1=$LENGTH($PIECE(MAX,":",1))

                   if LEN1>MLEN1

                       SET MLEN1=LEN1

 +11               SET LEN2=$LENGTH($PIECE(MAX,":",2))

                   if LEN2>MLEN2

                       SET MLEN2=LEN2

               End DoDot:1

 +12       SET TOTAL=LOOP(0)

           DO SET2(ITEMS,TOTAL,MLEN1,MLEN2)

 +13       QUIT 

SET2(TMP,TOTAL,MLEN1,MLEN2) ;

 +1        NEW MAX,COL,CT,LOOP,F1,F2,SP,Y

 +2        SET SP=""

           SET $PIECE(SP," ",80)=""

           SET MLEN=MLEN1+3+MLEN2+2

           SET CT=0

 +3        SET COL=(TOTAL\7)

           if (TOTAL/7)'=(TOTAL\7)

               SET COL=COL+1

 +4        SET MAX=80\COL

           SET MAX=MAX-2

           if MAX<MLEN

               SET MLEN=MAX

 +5        SET COL=COL-1

 +6        if COL=3&(TOTAL<8)

               SET COL=1

           IF $DATA(DJCP)

               XECUTE DJCP

               XECUTE XY

               WRITE DJLIN

 +7        FOR LOOP=1:1:TOTAL

               Begin DoDot:1

 +8                SET TEMP=$PIECE(TMP,";",LOOP)

                   SET F1=$PIECE(TEMP,":",1)

                   SET F2=$PIECE(TEMP,":",2)

 +9                SET F1=$EXTRACT(F1_SP,1,MLEN1)

                   SET F2=$EXTRACT(F2_SP,1,MLEN2)

 +10               IF CT>COL

                       SET CT=0

                       WRITE !

 +11               WRITE $GET(DJHIN),F1,$GET(DJLIN)," - ",F2,"  "

 +12               SET CT=CT+1

               End DoDot:1

 +13       DO HEADER("{Help prompt for Set of Codes}")

 +14       QUIT 

NUMBER(FILE,FIELD) ;

 +1        NEW VAL

 +2        SET VAL=$GET(^DD(FILE,FIELD,3))

           IF VAL=""

               SET MCERR=1

               QUIT 

 +3        DO HEADER("{Help prompt}")

 +4        IF $DATA(DJCP)

               XECUTE DJCP

               XECUTE XY

               WRITE DJLIN

 +5        WRITE !!,VAL

 +6        QUIT 

MULT(FILE,FIELD,XREC,FLAG) ;

 +1        NEW FIELDS,REC,EXC,DATA,TYPE,USER,TEMP,ERROR,LOOP,TOTAL,GLO,LEVEL

 +2        SET LEVEL=1

           SET FIELDS=FIELD

           SET REC=""

 +3        DO MAIN(FILE,.FIELDS,.LEVEL)

 +4        IF LEVEL>1

               FOR LOOP=1:1:LEVEL

                   SET REC=REC_^TMP($JOB,"DJST",LOOP,"DA")_U

 +5       IF '$TEST

               SET REC=XREC_U

               SET FIELDS=FIELD_U

 +6        SET REC=REC_1

           SET FIELDS=FIELDS_".01"

 +7       ;; ***ORIGINAL*** ;; S:$D(^DD(FILE,0,"UP")) FILE=^DD(FILE,0,"UP")

 +8       ;DAD81496

           FOR 

               SET FILE(0)=$GET(^DD(FILE,0,"UP"))

               if FILE(0)'>0

                   QUIT 

               SET FILE=FILE(0)

 +9        DO RTNELM^MCDBELM(FILE,REC,FIELDS,"","","E","",.TEMP,.ERROR)

 +10       SET GLO=TEMP("GLO")

 +11       FOR LOOP=0:0

               SET LOOP=+$ORDER(@GLO@(LOOP))

               if LOOP=0

                   QUIT 

               Begin DoDot:1

 +12               SET REC=+$PIECE($GET(@GLO@(LOOP,0)),U,1)

                   SET XHOLD(REC)=""

               End DoDot:1

 +13       QUIT 

MAIN(FILE,FIELDS,LEVEL) ;

 +1        NEW HOLD,NAME

 +2        SET HOLD=$GET(^DD(FILE,0,"UP"))

 +3        IF HOLD=""

               SET FIELDS=$$REORDER(FIELDS,LEVEL)

               QUIT 

 +4        SET NAME=$ORDER(^DD(FILE,0,"NM",""))

           SET LEVEL=LEVEL+1

 +5        SET FIELDS=$GET(FIELDS)_U_+$ORDER(^DD(HOLD,"B",NAME,0))

 +6        DO MAIN(HOLD,.FIELDS,LEVEL)

 +7        QUIT 

REORDER(FIELDS,LEVEL) ;

 +1        NEW LOOP,HOLD

           SET HOLD=""

           IF LEVEL<2

               QUIT ""

 +2        FOR LOOP=LEVEL:-1:1

               Begin DoDot:1

 +3                SET HOLD=HOLD_$PIECE(FIELDS,U,LOOP)_U

               End DoDot:1

 +4        QUIT HOLD

HEADER(MCHELP) ;

 +1        NEW SPACE,TEMP,TMP

           SET SPACE=""

           SET $PIECE(SPACE," ",80)=" "

 +2        SET DX=1

           SET DY=1

           XECUTE XY

 +3        SET TMP=40-$LENGTH(MCHELP)

 +4        SET TEMP=$EXTRACT(SPACE,1,TMP)_MCHELP

 +5        WRITE DJHIN,"*** Commands: ^C ",$SELECT($DATA(DJTOGGLE):"or KP1 ",1:""),"***",?40,TEMP,DJLIN

 +6        QUIT 

SCRN(SFILE,SFLD) ;

 +1        NEW SCREEN

 +2        IF $GET(^DD(SFILE,SFLD,12.1))'=""

               DO SCSET

 +3        IF '$DATA(SCREEN)

               Begin DoDot:1

 +4                SET SFILE=+$PIECE(^DD(SFILE,SFLD,0),U,2)

                   SET SFLD=.01

 +5                IF 'SFILE?1N.N1".".N

                       SET SFILE=+$PIECE(SFILE,"P",2)

 +6                IF $GET(^DD(SFILE,SFLD,12.1))'=""

                       DO SCSET

               End DoDot:1

 +7        QUIT $SELECT($DATA(SCREEN):SCREEN,1:"I 1")

SCSET     ;

 +1        IF ^DD(SFILE,SFLD,12.1)["S DIC(""S"")"

               XECUTE ^(12.1)

               SET SCREEN=DIC("S")

               KILL DIC("S")

               QUIT 

 +2        SET SCREEN=^DD(SFILE,SFLD,12.1)

           QUIT