DDSPTR ;SFISC/MKO-SET "PT" AND "PTB" NODES ;7JAN2004
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
PT(DDSDDP,EXP,DDS,PG,BK) ;Set "PT" and "PTB" nodes
N DDP,FDL,CD,FD
S DDP=DDSDDP
S $P(@DDSREFS@(PG,BK),U,8)=1
;
D:EXP?1"FO(".E FO(DDP,EXP,DDS,PG,BK,.CD,.FDL)
D:EXP'?1"FO(".E DD(DDP,EXP,BK,.CD,.FDL)
Q:$G(DIERR)
;
S:FDL?.E1"^" FDL=$E(FDL,1,$L(FDL)-1)
S @DDSREFS@(PG,BK,"PTB")=FDL
F CD=1:1:CD S @DDSREFS@(PG,BK,"PTB",CD)=CD(CD)
F CD=1:1:$L(FDL,U) D
. S FD=$P($P(FDL,U,CD),";"),DDP=+FD,FD=$P(FD,",",2,99)
. S @DDSREFS@("PT",DDP,FD,PG,BK)=""
Q
;
DD(DDP,EXP,BK,CD,FDL,COMP) ;Parse DD expression
;In:
; DDP = file #
; EXP = rel expr
; BK = blk # (to get DD# of blk)
; COMP = flag, EXP not pointer link
; 1, def is ext (DDSCOMP and DDSVAL)
; 2, def is int (DDSVAL)
;Returns:
; CD = array of code that sets DA
; FDL = list of flds used in expr
;
N FD1,FD2,P,TYP
I EXP?1"DD(".E D
. N I
. S I=$$RPAR^DDSLIB(EXP,3)
. S DDP=$P($E(EXP,4,I-2),",")
. S EXP=$P($E(EXP,4,I-2),",",2,999)_$E(EXP,I,999)
;
I $G(DDP)="" D BLD^DIALOG(202,"file") Q
;
LOOP S CD=$G(CD)+1
LOOP1 I $E(EXP)="""" D
. N I S I=$$AFTQ^DDSLIB(EXP)
. S FD1=$$UQT^DDSLIB($E(EXP,1,I-1)),FD2=$P($E(EXP,I,999),":",2,999)
. S P=$P($E(EXP,I,999),":")
E D
. S FD1=$P($P(EXP,":"),";"),FD2=$P(EXP,":",2,999)
. S P=$P($P(EXP,":"),";",2,999)
S FD1=$$FIELD^DDSLIB(DDP,FD1) Q:$G(DIERR)
;
S TYP=$P(^DD(DDP,FD1,0),U,2)
I TYP S DDP=+TYP,EXP=FD2 D:EXP="" BLD^DIALOG(3083) Q:EXP="" G LOOP1
;
I FD2="",$G(COMP) D Q
. S P=$S(COMP=1:P'["I",1:P["E")
. S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(P:","""",""E""",1:"")_")"
. S FDL=$G(FDL)_DDP_","_FD1_U
;
I TYP["V" D Q:$G(DIERR)
. S CD(CD)="S X=+$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_")"
. S FDL=$G(FDL)_DDP_","_FD1_U
. D GETFF(.FD2,.DDP)
E I TYP["P" D
. S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_")"
. S FDL=$G(FDL)_DDP_","_FD1_U
. S DDP=+$P(TYP,"P",2)
COMPTR E I TYP["Cp" D
.S CD(CD)="N D0 S D0=DA X $P(^DD("_DDP_","_FD1_",0),U,5,999) S X=X"
.S FDL=$G(FDL)_DDP_","_FD1_U
.S DDP=+$P(TYP,"p",2)
E D Q:$G(DIERR)
. N D,F,S
. S FDL=$G(FDL)_DDP_","_FD1_";J^"
. D LKPARM(P,.F,.D,.S)
. S CD(CD)="N D,DIC,Y S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(F:"",1:","""",""E""")_")"
. D GETFF(.FD2,.DDP) Q:$G(DIERR)
. I FD2="" D Q:$G(DIERR)
.. I $G(COMP) D BLD^DIALOG(3083) Q
.. S DDP=$P(^DIST(.404,BK,0),U,2)
. I DDP="" D BLD^DIALOG(202,"file") Q
. I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D Q
.. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
. S CD(CD)=CD(CD)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
;
I FD2]"" S EXP=FD2 G LOOP
S CD(CD)=CD(CD)_",DA=X"
Q
;
FO(DDP,EXP,DDS,PG,BK,CD,FDL,COMP) ;Parse FO expression
N FD1,FD2,I,P
;
S:'$D(DDS) DDS="" S:'$D(PG) PG="" S:'$D(BK) BK=""
S CD=1
S I=$$RPAR^DDSLIB(EXP,3)
S FD1=$E(EXP,4,I-2),P=$P($E(EXP,I,999),":")
S FD2=$P($E(EXP,I,999),":",2,999)
F I=1:1:3 S P(I)=$$PIECE^DDSLIB(FD1,",",I)
;
S FD1=$P($$GETFLD^DDSLIB(P(1),P(2),P(3),DDS,PG,BK,"F"),",",1,2)
Q:$G(DIERR)
;
I FD2="",$G(COMP) D Q
. S P=$S(COMP=1:P'["I",1:P["E")
. S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(P:"E",1:"")_""",DDSDA)"
. S FDL=$G(FDL)_"0,"_FD1_U
;
I $P($G(^DIST(.404,+$P(FD1,",",2),40,+FD1,20)),U)="" D Q
. N P S P(1)="READ TYPE",P(2)="form-only field in the BLOCK"
. D BLD^DIALOG(3011,.P)
;
I $P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U)["P" D
. S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""",DDSDA)"
. S FDL=$G(FDL)_"0,"_FD1_U
. S DDP=U_$P($P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U,3),":")
E D Q:$G(DIERR)
. N D,F,S
. S FDL=$G(FDL)_"0,"_FD1_";J^"
. D LKPARM(P,.F,.D,.S)
. S CD(1)="N D,DIC,Y S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(F:"",1:"E")_""",DDSDA)"
. D GETFF(.FD2,.DDP) Q:$G(DIERR)
. I FD2="" S DDP=$P(^DIST(.404,BK,0),U,2)
. I DDP="" D BLD^DIALOG(202,"file") Q
. I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D Q
.. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
. S CD(1)=CD(1)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
;
I FD2="" S CD(CD)=CD(CD)_",DA=X"
E S EXP=FD2 D DD(DDP,EXP,BK,.CD,.FDL,$G(COMP))
Q
;
GETFF(FD2,DDP) ;Get file, field
;Input: FD2=file:field:...
;Output: FD2=field:...
; DDP=file number
I $E(FD2)="""" D
. N I S I=$$AFTQ^DDSLIB(FD2,1)
. S DDP=$$UQT^DDSLIB($E(FD2,1,I-1)),FD2=$E(FD2,I,999)
E S DDP=$P(FD2,":"),FD2=$P(FD2,":",2,999)
;
I DDP]"",DDP'=+$P(DDP,"E") D
. I '$D(^DIC("B",DDP)) D BLD^DIALOG(3012,DDP) Q
. S DDP=$O(^DIC("B",DDP,""))
Q
;
LKPARM(P,F,D,S) ;Parse lookup params
;In: P = specifiers separated by ;
;Out: F = 1 if int form wanted
; D = code that sets D and DIC(0)
; S = code that calls ^DIC
N I,IP,L,M
S (D,F,L,M)=""
F I=1:1:$L(P,";") D
. S IP=$P(P,";",I) Q:IP=""
. I IP="I" S F=1 Q
. I IP="L" S L=1 Q
. I IP?.1"M"1"IX(".E1")" D Q
.. S IP=$P($P(IP,"(",2),")")
.. S:$E(IP)'="""" IP=$$QT^DDSLIB(IP)
.. S D=",D="_IP
.. I $L(IP,U)>1 S D=D_",DIC(0)=""MF""",S=" D MIX^DIC1"
.. E S D=D_",DIC(0)=""F""",S=" D IX^DIC"
S:D="" D=",DIC(0)=""MF""",S=" D ^DIC"
S D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$E("L",L)_""""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSPTR 5564 printed Dec 13, 2024@02:43:28 Page 2
DDSPTR ;SFISC/MKO-SET "PT" AND "PTB" NODES ;7JAN2004
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
PT(DDSDDP,EXP,DDS,PG,BK) ;Set "PT" and "PTB" nodes
+1 NEW DDP,FDL,CD,FD
+2 SET DDP=DDSDDP
+3 SET $PIECE(@DDSREFS@(PG,BK),U,8)=1
+4 ;
+5 if EXP?1"FO(".E
DO FO(DDP,EXP,DDS,PG,BK,.CD,.FDL)
+6 if EXP'?1"FO(".E
DO DD(DDP,EXP,BK,.CD,.FDL)
+7 if $GET(DIERR)
QUIT
+8 ;
+9 if FDL?.E1"^"
SET FDL=$EXTRACT(FDL,1,$LENGTH(FDL)-1)
+10 SET @DDSREFS@(PG,BK,"PTB")=FDL
+11 FOR CD=1:1:CD
SET @DDSREFS@(PG,BK,"PTB",CD)=CD(CD)
+12 FOR CD=1:1:$LENGTH(FDL,U)
Begin DoDot:1
+13 SET FD=$PIECE($PIECE(FDL,U,CD),";")
SET DDP=+FD
SET FD=$PIECE(FD,",",2,99)
+14 SET @DDSREFS@("PT",DDP,FD,PG,BK)=""
End DoDot:1
+15 QUIT
+16 ;
DD(DDP,EXP,BK,CD,FDL,COMP) ;Parse DD expression
+1 ;In:
+2 ; DDP = file #
+3 ; EXP = rel expr
+4 ; BK = blk # (to get DD# of blk)
+5 ; COMP = flag, EXP not pointer link
+6 ; 1, def is ext (DDSCOMP and DDSVAL)
+7 ; 2, def is int (DDSVAL)
+8 ;Returns:
+9 ; CD = array of code that sets DA
+10 ; FDL = list of flds used in expr
+11 ;
+12 NEW FD1,FD2,P,TYP
+13 IF EXP?1"DD(".E
Begin DoDot:1
+14 NEW I
+15 SET I=$$RPAR^DDSLIB(EXP,3)
+16 SET DDP=$PIECE($EXTRACT(EXP,4,I-2),",")
+17 SET EXP=$PIECE($EXTRACT(EXP,4,I-2),",",2,999)_$EXTRACT(EXP,I,999)
End DoDot:1
+18 ;
+19 IF $GET(DDP)=""
DO BLD^DIALOG(202,"file")
QUIT
+20 ;
LOOP SET CD=$GET(CD)+1
LOOP1 IF $EXTRACT(EXP)=""""
Begin DoDot:1
+1 NEW I
SET I=$$AFTQ^DDSLIB(EXP)
+2 SET FD1=$$UQT^DDSLIB($EXTRACT(EXP,1,I-1))
SET FD2=$PIECE($EXTRACT(EXP,I,999),":",2,999)
+3 SET P=$PIECE($EXTRACT(EXP,I,999),":")
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET FD1=$PIECE($PIECE(EXP,":"),";")
SET FD2=$PIECE(EXP,":",2,999)
+6 SET P=$PIECE($PIECE(EXP,":"),";",2,999)
End DoDot:1
+7 SET FD1=$$FIELD^DDSLIB(DDP,FD1)
if $GET(DIERR)
QUIT
+8 ;
+9 SET TYP=$PIECE(^DD(DDP,FD1,0),U,2)
+10 IF TYP
SET DDP=+TYP
SET EXP=FD2
if EXP=""
DO BLD^DIALOG(3083)
if EXP=""
QUIT
GOTO LOOP1
+11 ;
+12 IF FD2=""
IF $GET(COMP)
Begin DoDot:1
+13 SET P=$SELECT(COMP=1:P'["I",1:P["E")
+14 SET CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$SELECT(CD=1:".DA",1:"X")_","_FD1_$SELECT(P:","""",""E""",1:"")_")"
+15 SET FDL=$GET(FDL)_DDP_","_FD1_U
End DoDot:1
QUIT
+16 ;
+17 IF TYP["V"
Begin DoDot:1
+18 SET CD(CD)="S X=+$$GET^DDSVAL("_DDP_","_$SELECT(CD=1:".DA",1:"X")_","_FD1_")"
+19 SET FDL=$GET(FDL)_DDP_","_FD1_U
+20 DO GETFF(.FD2,.DDP)
End DoDot:1
if $GET(DIERR)
QUIT
+21 IF '$TEST
IF TYP["P"
Begin DoDot:1
+22 SET CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$SELECT(CD=1:".DA",1:"X")_","_FD1_")"
+23 SET FDL=$GET(FDL)_DDP_","_FD1_U
+24 SET DDP=+$PIECE(TYP,"P",2)
End DoDot:1
COMPTR IF '$TEST
IF TYP["Cp"
Begin DoDot:1
+1 SET CD(CD)="N D0 S D0=DA X $P(^DD("_DDP_","_FD1_",0),U,5,999) S X=X"
+2 SET FDL=$GET(FDL)_DDP_","_FD1_U
+3 SET DDP=+$PIECE(TYP,"p",2)
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 NEW D,F,S
+6 SET FDL=$GET(FDL)_DDP_","_FD1_";J^"
+7 DO LKPARM(P,.F,.D,.S)
+8 SET CD(CD)="N D,DIC,Y S X=$$GET^DDSVAL("_DDP_","_$SELECT(CD=1:".DA",1:"X")_","_FD1_$SELECT(F:"",1:","""",""E""")_")"
+9 DO GETFF(.FD2,.DDP)
if $GET(DIERR)
QUIT
+10 IF FD2=""
Begin DoDot:2
+11 IF $GET(COMP)
DO BLD^DIALOG(3083)
QUIT
+12 SET DDP=$PIECE(^DIST(.404,BK,0),U,2)
End DoDot:2
if $GET(DIERR)
QUIT
+13 IF DDP=""
DO BLD^DIALOG(202,"file")
QUIT
+14 IF '$DATA(^DD(DDP))!'$DATA(^DIC(DDP,0,"GL"))
Begin DoDot:2
+15 NEW P
SET P("FILE")=DDP
DO BLD^DIALOG(401,.P)
End DoDot:2
QUIT
+16 SET CD(CD)=CD(CD)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
End DoDot:1
if $GET(DIERR)
QUIT
+17 ;
+18 IF FD2]""
SET EXP=FD2
GOTO LOOP
+19 SET CD(CD)=CD(CD)_",DA=X"
+20 QUIT
+21 ;
FO(DDP,EXP,DDS,PG,BK,CD,FDL,COMP) ;Parse FO expression
+1 NEW FD1,FD2,I,P
+2 ;
+3 if '$DATA(DDS)
SET DDS=""
if '$DATA(PG)
SET PG=""
if '$DATA(BK)
SET BK=""
+4 SET CD=1
+5 SET I=$$RPAR^DDSLIB(EXP,3)
+6 SET FD1=$EXTRACT(EXP,4,I-2)
SET P=$PIECE($EXTRACT(EXP,I,999),":")
+7 SET FD2=$PIECE($EXTRACT(EXP,I,999),":",2,999)
+8 FOR I=1:1:3
SET P(I)=$$PIECE^DDSLIB(FD1,",",I)
+9 ;
+10 SET FD1=$PIECE($$GETFLD^DDSLIB(P(1),P(2),P(3),DDS,PG,BK,"F"),",",1,2)
+11 if $GET(DIERR)
QUIT
+12 ;
+13 IF FD2=""
IF $GET(COMP)
Begin DoDot:1
+14 SET P=$SELECT(COMP=1:P'["I",1:P["E")
+15 SET CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$SELECT(P:"E",1:"")_""",DDSDA)"
+16 SET FDL=$GET(FDL)_"0,"_FD1_U
End DoDot:1
QUIT
+17 ;
+18 IF $PIECE($GET(^DIST(.404,+$PIECE(FD1,",",2),40,+FD1,20)),U)=""
Begin DoDot:1
+19 NEW P
SET P(1)="READ TYPE"
SET P(2)="form-only field in the BLOCK"
+20 DO BLD^DIALOG(3011,.P)
End DoDot:1
QUIT
+21 ;
+22 IF $PIECE(^DIST(.404,+$PIECE(FD1,",",2),40,+FD1,20),U)["P"
Begin DoDot:1
+23 SET CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""",DDSDA)"
+24 SET FDL=$GET(FDL)_"0,"_FD1_U
+25 SET DDP=U_$PIECE($PIECE(^DIST(.404,+$PIECE(FD1,",",2),40,+FD1,20),U,3),":")
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 NEW D,F,S
+28 SET FDL=$GET(FDL)_"0,"_FD1_";J^"
+29 DO LKPARM(P,.F,.D,.S)
+30 SET CD(1)="N D,DIC,Y S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$SELECT(F:"",1:"E")_""",DDSDA)"
+31 DO GETFF(.FD2,.DDP)
if $GET(DIERR)
QUIT
+32 IF FD2=""
SET DDP=$PIECE(^DIST(.404,BK,0),U,2)
+33 IF DDP=""
DO BLD^DIALOG(202,"file")
QUIT
+34 IF '$DATA(^DD(DDP))!'$DATA(^DIC(DDP,0,"GL"))
Begin DoDot:2
+35 NEW P
SET P("FILE")=DDP
DO BLD^DIALOG(401,.P)
End DoDot:2
QUIT
+36 SET CD(1)=CD(1)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
End DoDot:1
if $GET(DIERR)
QUIT
+37 ;
+38 IF FD2=""
SET CD(CD)=CD(CD)_",DA=X"
+39 IF '$TEST
SET EXP=FD2
DO DD(DDP,EXP,BK,.CD,.FDL,$GET(COMP))
+40 QUIT
+41 ;
GETFF(FD2,DDP) ;Get file, field
+1 ;Input: FD2=file:field:...
+2 ;Output: FD2=field:...
+3 ; DDP=file number
+4 IF $EXTRACT(FD2)=""""
Begin DoDot:1
+5 NEW I
SET I=$$AFTQ^DDSLIB(FD2,1)
+6 SET DDP=$$UQT^DDSLIB($EXTRACT(FD2,1,I-1))
SET FD2=$EXTRACT(FD2,I,999)
End DoDot:1
+7 IF '$TEST
SET DDP=$PIECE(FD2,":")
SET FD2=$PIECE(FD2,":",2,999)
+8 ;
+9 IF DDP]""
IF DDP'=+$PIECE(DDP,"E")
Begin DoDot:1
+10 IF '$DATA(^DIC("B",DDP))
DO BLD^DIALOG(3012,DDP)
QUIT
+11 SET DDP=$ORDER(^DIC("B",DDP,""))
End DoDot:1
+12 QUIT
+13 ;
LKPARM(P,F,D,S) ;Parse lookup params
+1 ;In: P = specifiers separated by ;
+2 ;Out: F = 1 if int form wanted
+3 ; D = code that sets D and DIC(0)
+4 ; S = code that calls ^DIC
+5 NEW I,IP,L,M
+6 SET (D,F,L,M)=""
+7 FOR I=1:1:$LENGTH(P,";")
Begin DoDot:1
+8 SET IP=$PIECE(P,";",I)
if IP=""
QUIT
+9 IF IP="I"
SET F=1
QUIT
+10 IF IP="L"
SET L=1
QUIT
+11 IF IP?.1"M"1"IX(".E1")"
Begin DoDot:2
+12 SET IP=$PIECE($PIECE(IP,"(",2),")")
+13 if $EXTRACT(IP)'=""""
SET IP=$$QT^DDSLIB(IP)
+14 SET D=",D="_IP
+15 IF $LENGTH(IP,U)>1
SET D=D_",DIC(0)=""MF"""
SET S=" D MIX^DIC1"
+16 IF '$TEST
SET D=D_",DIC(0)=""F"""
SET S=" D IX^DIC"
End DoDot:2
QUIT
End DoDot:1
+17 if D=""
SET D=",DIC(0)=""MF"""
SET S=" D ^DIC"
+18 SET D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$EXTRACT("L",L)_""""
+19 QUIT
