Annotation of freem_fileman/DDS2.m, revision 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.
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDS2.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman