Return to DDS2.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDS2.m, revision 1.1.1.1

1.1       snw         1: DDS2   ;SFISC/MLH-UP ARROW JUMP, BRANCH ;02:18 PM  21 Dec 1994
                      2:        ;;21.0;VA FileMan;;Dec 28, 1994
                      3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
                      4: UPA    ;
                      5:        I X?1"^"1.E,X'="^^",$G(DDSDN) D MSG^DDSMSG("No jumping allowed.",1) Q
                      6:        I X?1"^"1.E,X'="^^" D JMP Q
                      7:        I $E(X)=U,$D(DDSREP),DA D END^DDSM Q
                      8:        I $E(X)=U,DDO,$G(DDSDN)=1 D MSG^DDSMSG("No exit allowed, since navigation for the block is disabled.",1) Q
                      9:        I $E(X)=U,DDO S DDSOSV=DDO,DDO=0 Q
                     10:        I $E(X)=U,'DDO D E^DDS3 Q
                     11:        Q
                     12:        ;
                     13: JMP    ;Up-arrow jump
                     14:        S DDS2X=X,X=$P(X,U,2) I X="" W $C(7) G KILL
                     15:        K DDH,DDQ S DDH=0
                     16:        S (X,DDSX)=$$UPCASE($E(X,1,63))
                     17:        ;
                     18:        ;Find exact matches
                     19:        D:$D(@DDSREFS@("CAP",X)) CAP
                     20:        D:$D(@DDSREFT@("XCAP",DDSPG,DDSBK,X)) XCAP
                     21:        ;
                     22:        ;Find partial matches
                     23:        S:X="?" (X,DDSX)=""
                     24:        F  S DDSX=$O(@DDSREFS@("CAP",DDSX)) Q:DDSX=""!($P(DDSX,X)]"")  D CAP
                     25:        S DDSX=X F  S DDSX=$O(@DDSREFT@("XCAP",DDSPG,DDSBK,DDSX)) Q:DDSX=""!($P(DDSX,X)]"")  D XCAP
                     26:        ;
                     27:        I 'DDH D MSG^DDSMSG($P(DDS2X,U,2)_" not found.",1) G KILL
                     28:        S DDS2O=DDO
                     29:        I DDH=1 S DDO=$O(DDH(DDH,""))
                     30:        E  S DDD="J" D SC^DDSU
                     31:        ;
                     32:        S DDS2B=$P(DDO,",",2),DDS2P=$P(DDO,",",3),DDO=+DDO
                     33:        G:'DDS2B KILL
                     34:        ;
                     35:        S DDS2DA=DDSDA
                     36:        I DDS2P'=DDSPG D
                     37:        . D:'$D(@DDSREFT@(DDS2P,DDS2B)) ^DDS1(DDS2P)
                     38:        . S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
                     39:        . I DDS2DA="" D
                     40:        .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
                     41:        .. S DDO=DDS2O
                     42:        . E  D
                     43:        .. D CKUNED
                     44:        .. I '$G(DDS2UNED) S DDACT="NP",DDSPG=DDS2P,DDSBK=DDS2B,DDSBR=""
                     45:        ;
                     46:        E  I DDS2B'=DDSBK D
                     47:        . S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
                     48:        . I DDS2DA="" D
                     49:        .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
                     50:        .. S DDO=DDS2O
                     51:        . E  I $P($G(@DDSREFS@(DDS2P,DDS2B)),U,4) D
                     52:        .. D MSG^DDSMSG($C(7)_$P($T(ERR1),";;",2))
                     53:        .. S DDO=DDS2O
                     54:        . E  D CKUNED I '$G(DDS2UNED) S DDACT="NB",DDSBK=DDS2B,DDSBR=""
                     55:        ;
                     56:        E  D CKUNED I '$G(DDS2UNED) S DDACT="N"
                     57:        ;
                     58: KILL   S X=DDS2X
                     59:        K DDH,DDSI,DDSPGRP,DDSX
                     60:        K DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X
                     61:        Q
                     62:        ;
                     63: CKUNED ;Check uneditable status
                     64:        N DDP,DDSFLD
                     65:        ;
                     66:        I $P($G(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2 D
                     67:        . S DDP=0
                     68:        . S DDSFLD=+DDO_","_DDS2B
                     69:        E  D
                     70:        . S DDP=$P($G(@DDSREFS@(DDS2P,DDS2B)),U,3)
                     71:        . S DDSFLD=$P($G(^DIST(.404,DDS2B,40,+DDO,1)),U)
                     72:        ;
                     73:        S DDS2ATT=$P($G(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4)
                     74:        ;
                     75:        I DDO,$S(DDS2ATT="":$P($G(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1),'$P(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11) D
                     76:        . D MSG^DDSMSG($P(^DIST(.404,DDS2B,40,+DDO,0),U,2)_" is uneditable.",1)
                     77:        . S DDS2UNED=1,DDO=DDS2O
                     78:        Q
                     79:        ;
                     80: CAP    ;Find all captions that match DDSX
                     81:        S DDSPGRP=""
                     82:        F  S DDSPGRP=$O(@DDSREFS@("CAP",DDSX,DDSPGRP)) Q:DDSPGRP=""  D
                     83:        . Q:U_DDSPGRP_U'[(U_DDSPG_U)
                     84:        . S DDS2P="" F  S DDS2P=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P)) Q:'DDS2P  S DDS2B="" F  S DDS2B=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B)) Q:'DDS2B  S DDS2F="" F  S DDS2F=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F)) Q:'DDS2F  D FILL
                     85:        Q
                     86:        ;
                     87: XCAP   ;Find all xecutable captions that match DDSX
                     88:        S DDSI=0
                     89:        F  S DDSI=$O(@DDSREFT@("XCAP",DDSPG,DDSBK,DDSX,DDSI)) Q:'DDSI  D
                     90:        . I $D(^DIST(.404,DDSBK,40,DDSI,0))#2,$P(^(0),U,3)'=1 D FILL
                     91:        Q
                     92:        ;
                     93: FILL   ;Fill DDH array with possible choices
                     94:        S DDS2V=DDSX_$S($P(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
                     95:        S:DDS2P'=DDSPG DDS2V=DDS2V_" ("_$S($P($G(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))_")"
                     96:        S DDH=DDH+1,DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V
                     97:        K DDS2V
                     98:        Q
                     99:        ;
                    100: BR     ;Evaluate DDSBR
                    101:        N B,B1,F,F1,P,P1,E,X Q:$D(DDSBR)[0
                    102:        S P=$P($G(DDSOPB),U),B=$P($G(DDSOPB),U,2),F=$G(DDO),E=1
                    103:        S:'B B=+$P(@DDSREFS@(+P,"FIRST"),",",2)
                    104:        S P1=$P(DDSBR,U,3),B1=$P(DDSBR,U,2),F1=$P(DDSBR,U)
                    105:        ;
                    106:        D @$S(P1]"":"PG",B1]"":"BK",1:"FD")
                    107:        S:'E DDACT=$S(P'=+DDSOPB:"NP",B'=$P(DDSOPB,U,2):"NB",1:"N"),DDSPG=P,DDSBK=B,DDO=F
                    108:        K:E DDSBR
                    109:        Q
                    110: PG     ;
                    111:        I P1=+$P(P1,"E") S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
                    112:        E  S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),""))
                    113:        Q:'P
                    114:        S:'B1 B1=$O(^DIST(.403,+DDS,40,P,40,"AC","")) Q:B1=""
                    115: BK     ;
                    116:        I B1=+$P(B1,"E") D
                    117:        . S B=$O(^DIST(.403,+DDS,40,P,40,"AC",B1,""))
                    118:        E  D
                    119:        . S B=$O(^DIST(.404,"B",B1,"")) Q:B=""
                    120:        . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
                    121:        Q:'B
                    122:        S:F1="" F1=$O(^DIST(.404,B,40,"B",""))
                    123: FD     ;
                    124:        Q:F1=""
                    125:        I F1="COM" S (E,F)=0 Q
                    126:        I F1=+$P(F1,"E") S X="B"
                    127:        E  S F1=$$UPCASE(F1),X=$S($D(^DIST(.404,B,40,"D",F1)):"D",1:"C")
                    128:        S F=$O(^DIST(.404,B,40,X,F1,""))
                    129:        S:F E=0
                    130:        Q
                    131:        ;
                    132: UPCASE(X)      ;
                    133:        ;Return X in uppercase
                    134:        Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
                    135:        ;
                    136: ERR    ;;Unable to jump to that field.  The block on which that field is located has no record associated with it.
                    137:        ;
                    138: ERR1   ;;Unable to jump to that field.  The block on which that field is located has navigation disabled.