Annotation of freem_fileman/USER/DDSPTR.m, revision 1.1
1.1 ! snw 1: DDSPTR ;SFISC/MKO-SET "PT" AND "PTB" NODES ;09:46 AM 24 Oct 1994
! 2: ;;21.0;VA FileMan;;Dec 28, 1994
! 3: ;Per VHA Directive 10-93-142, this routine should not be modified.
! 4: ;
! 5: PT(DDSDDP,EXP,DDS,PG,BK) ;Set "PT" and "PTB" nodes
! 6: N DDP,FDL,CD,FD
! 7: S DDP=DDSDDP
! 8: S $P(@DDSREFS@(PG,BK),U,8)=1
! 9: ;
! 10: D:EXP?1"FO(".E FO(DDP,EXP,DDS,PG,BK,.CD,.FDL)
! 11: D:EXP'?1"FO(".E DD(DDP,EXP,BK,.CD,.FDL)
! 12: Q:$G(DIERR)
! 13: ;
! 14: S:FDL?.E1"^" FDL=$E(FDL,1,$L(FDL)-1)
! 15: S @DDSREFS@(PG,BK,"PTB")=FDL
! 16: F CD=1:1:CD S @DDSREFS@(PG,BK,"PTB",CD)=CD(CD)
! 17: F CD=1:1:$L(FDL,U) D
! 18: . S FD=$P($P(FDL,U,CD),";"),DDP=+FD,FD=$P(FD,",",2,99)
! 19: . S @DDSREFS@("PT",DDP,FD,PG,BK)=""
! 20: Q
! 21: ;
! 22: DD(DDP,EXP,BK,CD,FDL,COMP) ;Parse DD expression
! 23: ;In:
! 24: ; DDP = file #
! 25: ; EXP = rel expr
! 26: ; BK = blk # (to get DD# of blk)
! 27: ; COMP = flag, EXP not pointer link
! 28: ; 1, def is ext (DDSCOMP and DDSVAL)
! 29: ; 2, def is int (DDSVAL)
! 30: ;Returns:
! 31: ; CD = array of code that sets DA
! 32: ; FDL = list of flds used in expr
! 33: ;
! 34: N FD1,FD2,P,PF
! 35: I $G(DDP)="" D BLD^DIALOG(202,"file") Q
! 36: LOOP S CD=$G(CD)+1
! 37: LOOP1 I $E(EXP)="""" D
! 38: . N I S I=$$AFTQ^DDSLIB(EXP)
! 39: . S FD1=$$UQT^DDSLIB($E(EXP,1,I-1)),FD2=$P($E(EXP,I,999),":",2,999)
! 40: . S P=$P($E(EXP,I,999),":")
! 41: E D
! 42: . S FD1=$P($P(EXP,":"),";"),FD2=$P(EXP,":",2,999)
! 43: . S P=$P($P(EXP,":"),";",2,999)
! 44: S FD1=$$FIELD^DDSLIB(DDP,FD1) Q:$G(DIERR)
! 45: ;
! 46: S PF=$P(^DD(DDP,FD1,0),U,2)
! 47: I PF S DDP=+PF,EXP=FD2 D:EXP="" BLD^DIALOG(3083) Q:EXP="" G LOOP1
! 48: ;
! 49: I FD2="",$G(COMP) D Q
! 50: . S P=$S(COMP=1:P'["I",1:P["E")
! 51: . S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(P:","""",""E""",1:"")_")"
! 52: . S FDL=$G(FDL)_DDP_","_FD1_U
! 53: ;
! 54: S PF=+$P(PF,"P",2)
! 55: I PF D
! 56: . S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_")"
! 57: . S FDL=$G(FDL)_DDP_","_FD1_U
! 58: . S DDP=PF
! 59: E D Q:$G(DIERR)
! 60: . N D,F,S
! 61: . S FDL=$G(FDL)_DDP_","_FD1_";J^"
! 62: . D LKPARM(P,.F,.D,.S)
! 63: . S CD(CD)="N D,DIC,Y S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(F:"",1:","""",""E""")_")"
! 64: . D GETFF(.FD2,.DDP) Q:$G(DIERR)
! 65: . I FD2="" D Q:$G(DIERR)
! 66: .. I $G(COMP) D BLD^DIALOG(3083) Q
! 67: .. S DDP=$P(^DIST(.404,BK,0),U,2)
! 68: . I DDP="" D BLD^DIALOG(202,"file") Q
! 69: . I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D Q
! 70: .. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
! 71: . S CD(CD)=CD(CD)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
! 72: ;
! 73: I FD2]"" S EXP=FD2 G LOOP
! 74: S CD(CD)=CD(CD)_",DA=X"
! 75: Q
! 76: ;
! 77: FO(DDP,EXP,DDS,PG,BK,CD,FDL,COMP) ;Parse FO expression
! 78: N FD1,FD2,I,P
! 79: ;
! 80: S:'$D(DDS) DDS="" S:'$D(PG) PG="" S:'$D(BK) BK=""
! 81: S CD=1
! 82: S I=$$RPAR^DDSLIB(EXP,3)
! 83: S FD1=$E(EXP,4,I-2),P=$P($E(EXP,I,999),":")
! 84: S FD2=$P($E(EXP,I,999),":",2,999)
! 85: F I=1:1:3 S P(I)=$$PIECE^DDSLIB(FD1,",",I)
! 86: ;
! 87: S FD1=$P($$GETFLD^DDSLIB(P(1),P(2),P(3),DDS,PG,BK,"F"),",",1,2)
! 88: Q:$G(DIERR)
! 89: ;
! 90: I FD2="",$G(COMP) D Q
! 91: . S P=$S(COMP=1:P'["I",1:P["E")
! 92: . S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(P:"E",1:"")_""",DDSDA)"
! 93: . S FDL=$G(FDL)_"0,"_FD1_U
! 94: ;
! 95: I $P($G(^DIST(.404,+$P(FD1,",",2),40,+FD1,20)),U)="" D Q
! 96: . N P S P(1)="READ TYPE",P(2)="form-only field in the BLOCK"
! 97: . D BLD^DIALOG(3011,.P)
! 98: ;
! 99: I $P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U)["P" D
! 100: . S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""",DDSDA)"
! 101: . S FDL=$G(FDL)_"0,"_FD1_U
! 102: . S DDP=U_$P($P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U,3),":")
! 103: E D Q:$G(DIERR)
! 104: . N D,F,S
! 105: . S FDL=$G(FDL)_"0,"_FD1_";J^"
! 106: . D LKPARM(P,.F,.D,.S)
! 107: . S CD(1)="N D,DIC,Y S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(F:"",1:"E")_""",DDSDA)"
! 108: . D GETFF(.FD2,.DDP) Q:$G(DIERR)
! 109: . I FD2="" S DDP=$P(^DIST(.404,BK,0),U,2)
! 110: . I DDP="" D BLD^DIALOG(202,"file") Q
! 111: . I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D Q
! 112: .. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
! 113: . S CD(1)=CD(1)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
! 114: ;
! 115: I FD2="" S CD(CD)=CD(CD)_",DA=X"
! 116: E S EXP=FD2 D DD(DDP,EXP,BK,.CD,.FDL,$G(COMP))
! 117: Q
! 118: ;
! 119: GETFF(FD2,DDP) ;Get file, field
! 120: ;Input: FD2=file:field:...
! 121: ;Output: FD2=field:...
! 122: ; DDP=file number
! 123: I $E(FD2)="""" D
! 124: . N I S I=$$AFTQ^DDSLIB(FD2,1)
! 125: . S DDP=$$UQT^DDSLIB($E(FD2,1,I-1)),FD2=$E(FD2,I,999)
! 126: E S DDP=$P(FD2,":"),FD2=$P(FD2,":",2,999)
! 127: ;
! 128: I DDP]"",DDP'=+$P(DDP,"E") D
! 129: . I '$D(^DIC("B",DDP)) D BLD^DIALOG(3012,DDP) Q
! 130: . S DDP=$O(^DIC("B",DDP,""))
! 131: Q
! 132: ;
! 133: LKPARM(P,F,D,S) ;Parse lookup params
! 134: ;In: P = specifiers separated by ;
! 135: ;Out: F = 1 if int form wanted
! 136: ; D = code that sets D and DIC(0)
! 137: ; S = code that calls ^DIC
! 138: N I,IP,L,M
! 139: S (D,F,L,M)=""
! 140: F I=1:1:$L(P,";") D
! 141: . S IP=$P(P,";",I) Q:IP=""
! 142: . I IP="I" S F=1 Q
! 143: . I IP="L" S L=1 Q
! 144: . I IP?.1"M"1"IX(".E1")" D Q
! 145: .. S IP=$P($P(IP,"(",2),")")
! 146: .. S:$E(IP)'="""" IP=$$QT^DDSLIB(IP)
! 147: .. S D=",D="_IP
! 148: .. I $L(IP,U)>1 S D=D_",DIC(0)=""MF""",S=" D MIX^DIC1"
! 149: .. E S D=D_",DIC(0)=""F""",S=" D IX^DIC"
! 150: S:D="" D=",DIC(0)=""MF""",S=" D ^DIC"
! 151: S D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$E("L",L)_""""
! 152: Q
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDSPTR.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman / USER