- DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;11:40 AM 26 Aug 1999 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**8**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN(SC,N,O,RNAV) ;
- ;Input:
- ; DDSPG
- ; DDSREFS
- ;
- D SCR(.SC),NAV(.N,.RNAV),ORD(.O)
- D:$D(RNAV) RNAV(.RNAV,.O)
- Q
- ;
- SCR(SC) ;Move image from SC to global
- N C,P,R,S
- Q:'$D(SC)
- S R=0 F S R=$O(SC(R)) Q:'R D
- . F C=1:1 Q:$E(SC(R),C)'=" "
- . S @DDSREFS@("X",DDSPG,R-1,C-1)=$TR($E(SC(R),C,999),$C(0)," ")
- . I $D(SC(R))=11 D
- .. S S="",P=0
- .. F S P=$O(SC(R,P)) Q:'P S S=S_(P-C+1)_";"_(SC(R,P)-C+1)_";U"_U
- .. S:S?.E1"^" S=$E(S,1,$L(S)-1)
- .. S:S]"" @DDSREFS@("X",DDSPG,R-1,C-1,"A")=S
- Q
- ;
- NAV(N,RNAV) ;
- N B,D1,D2,F,LN
- S N(9999,1)="0,0"
- ;
- S D1="" F S D1=$O(N(D1)) Q:D1="" D
- . S D2="" F S D2=$O(N(D1,D2)) Q:D2="" D
- .. S F=$P(N(D1,D2),","),B=$P(N(D1,D2),",",2),LN=""
- .. D NAV1(.N,.RNAV,D1,D2,.LN)
- .. S @DDSREFS@(DDSPG,B,F,"N")=LN
- .. S:$D(DDSMUL(B,F)) $P(@DDSREFS@(DDSPG,B,F,"N"),U,11)=1
- Q
- ;
- NAV1(N,RNAV,D1,D2,LN) ;Setup "N" for navigation
- N E1,E2,I
- ;
- S E1=$S($O(N(D1),-1)]"":$O(N(D1),-1),1:$O(N(""),-1))
- S E2=D2
- I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2)))
- I E1]"",E2]"" D
- . N RBO
- . S RBO=$P(N(E1,E2),",",3)
- . I RBO,$D(RNAV(RBO,E1))#2 D Q:E2=""
- .. S E2="" F S E2=$O(RNAV(RBO,E1,E2)) Q:E2="" Q:RNAV(RBO,E1,E2)'[","
- . S $P(LN,U)=$P(N(E1,E2),",",1,2)
- ;
- S E1=$S($O(N(D1))]"":$O(N(D1)),1:$O(N("")))
- S E2=D2
- I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2)))
- I E1]"",E2]"" D
- . N RBO
- . S RBO=$P(N(E1,E2),",",3)
- . I RBO,$D(RNAV(RBO,E1))#2 D Q:E2=""
- .. S E2="" F S E2=$O(RNAV(RBO,E1,E2)) Q:E2="" Q:RNAV(RBO,E1,E2)'[","
- . S $P(LN,U,2)=$P(N(E1,E2),",",1,2)
- ;
- S E1=D1,E2=$O(N(D1,D2))
- I E2="" S E1=$S($O(N(E1))]"":$O(N(E1)),1:$O(N(""))),E2=$O(N(E1,""))
- I E1]"",E2]"" S $P(LN,U,3)=$P(N(E1,E2),",",1,2)
- ;
- S E1=D1,E2=$S($O(N(E1,D2),-1)]"":$O(N(E1,D2),-1),1:"")
- I E2="" S E1=$S($O(N(E1),-1)]"":$O(N(E1),-1),1:$O(N(""),-1)),E2=$S($O(N(E1,""),-1)]"":$O(N(E1,""),-1),1:"")
- I E1]"",E2]"" S $P(LN,U,4)=$P(N(E1,E2),",",1,2)
- ;
- F I=1:1:4 S:$P($P(LN,U,I),",",2)=B!'$P($P(LN,U,I),",",2) $P(LN,U,I)=+$P(LN,U,I)
- Q
- ;
- ORD(O) ;Setup field order info
- N B,BO,BP,F,FO,FP
- S (BO,FO)="" F S BO=$O(O(BO)) Q:BO="" S FO=$O(O(BO,"")) Q:FO]""
- S:FO="" BO=$O(O(""))
- S B=+$G(O(+BO)),F=+$G(O(+BO,+FO))
- S @DDSREFS@(DDSPG,"FIRST")=F_","_B
- ;
- S (BP,FP)=0
- S BO="" F S BO=$O(O(BO)) Q:BO="" D
- . S B=+O(BO),F=0
- . S FO=$O(O(BO,"")) S:FO]"" F=O(BO,FO)
- . S $P(@DDSREFS@(DDSPG,B),U,9)=F
- . S:$P(O(BO),U,2)]"" $P(@DDSREFS@(DDSPG,B),U,10)=$S($P(O(BO),U,2)="FIRST":F,1:$P(O(BO),U,2))
- . S FO="" F S FO=$O(O(BO,FO)) Q:FO="" D
- .. S F=O(BO,FO)
- .. S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=F_$S(B'=BP:","_B,1:"")
- .. S FP=F,BP=B
- S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=0
- Q
- ;
- RNAV(DDSRNAV,DDSO) ;Setup nav and fo info for rep blocks
- N DDSBO,DDSN,B,D1,D2,DN,F,F1,FO,LN,NX,RT
- S DDSBO="" F S DDSBO=$O(DDSRNAV(DDSBO)) Q:DDSBO="" D
- . ;N %X,%Y K DDSN S %X="DDSRNAV("_DDSBO_",",%Y="DDSN(" D %XY^%RCR
- . K DDSN M DDSN=DDSRNAV(DDSBO)
- . S D1="" F S D1=$O(DDSN(D1)) Q:D1="" D:$D(DDSN(D1))#2
- .. S B=DDSN(D1)
- .. S D2="" F S D2=$O(DDSN(D1,D2)) Q:D2="" D
- ... S F=DDSN(D1,D2),LN="" Q:F[","
- ... D NAV1(.DDSN,.DDSRNAV,D1,D2,.LN)
- ... S $P(@DDSREFS@(DDSPG,B,F,"N"),U,6,9)=LN
- . ;
- . S B=+$G(DDSO(+DDSBO)) Q:'B
- . S FO=$O(DDSO(DDSBO,"")) Q:FO=""
- . S (F,F1)=DDSO(DDSBO,FO)
- . F S FO=$O(DDSO(DDSBO,FO)) Q:FO="" D
- .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=DDSO(DDSBO,FO)
- .. S F=DDSO(DDSBO,FO)
- . S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=F1_",+1"
- . ;
- . S DN=0
- . S F=0 F S F=$O(@DDSREFS@(DDSPG,B,F)) Q:DN=2!(F="") D
- .. S LN=$G(@DDSREFS@(DDSPG,B,F,"N")) Q:LN=""
- .. S RT=$P(LN,U,3),NX=$P(LN,U,5)
- .. S:RT[","!'RT DN=DN+1
- .. S:NX[","!'NX DN=DN+1
- . ;
- . S F=0 F S F=$O(@DDSREFS@(DDSPG,B,F)) Q:F="" D
- .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,3)=RT
- .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,5)=NX
- Q
- DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;11:40 AM 26 Aug 1999 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**8**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN(SC,N,O,RNAV) ;
- +1 ;Input:
- +2 ; DDSPG
- +3 ; DDSREFS
- +4 ;
- +5 DO SCR(.SC)
- DO NAV(.N,.RNAV)
- DO ORD(.O)
- +6 IF $DATA(RNAV)
- DO RNAV(.RNAV,.O)
- +7 QUIT
- +8 ;
- SCR(SC) ;Move image from SC to global
- +1 NEW C,P,R,S
- +2 IF '$DATA(SC)
- QUIT
- +3 SET R=0
- FOR
- SET R=$ORDER(SC(R))
- IF 'R
- QUIT
- Begin DoDot:1
- +4 FOR C=1:1
- IF $EXTRACT(SC(R),C)'=" "
- QUIT
- +5 SET @DDSREFS@("X",DDSPG,R-1,C-1)=$TRANSLATE($EXTRACT(SC(R),C,999),$CHAR(0)," ")
- +6 IF $DATA(SC(R))=11
- Begin DoDot:2
- +7 SET S=""
- SET P=0
- +8 FOR
- SET P=$ORDER(SC(R,P))
- IF 'P
- QUIT
- SET S=S_(P-C+1)_";"_(SC(R,P)-C+1)_";U"_U
- +9 IF S?.E1"^"
- SET S=$EXTRACT(S,1,$LENGTH(S)-1)
- +10 IF S]""
- SET @DDSREFS@("X",DDSPG,R-1,C-1,"A")=S
- End DoDot:2
- End DoDot:1
- +11 QUIT
- +12 ;
- NAV(N,RNAV) ;
- +1 NEW B,D1,D2,F,LN
- +2 SET N(9999,1)="0,0"
- +3 ;
- +4 SET D1=""
- FOR
- SET D1=$ORDER(N(D1))
- IF D1=""
- QUIT
- Begin DoDot:1
- +5 SET D2=""
- FOR
- SET D2=$ORDER(N(D1,D2))
- IF D2=""
- QUIT
- Begin DoDot:2
- +6 SET F=$PIECE(N(D1,D2),",")
- SET B=$PIECE(N(D1,D2),",",2)
- SET LN=""
- +7 DO NAV1(.N,.RNAV,D1,D2,.LN)
- +8 SET @DDSREFS@(DDSPG,B,F,"N")=LN
- +9 IF $DATA(DDSMUL(B,F))
- SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,11)=1
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- NAV1(N,RNAV,D1,D2,LN) ;Setup "N" for navigation
- +1 NEW E1,E2,I
- +2 ;
- +3 SET E1=$SELECT($ORDER(N(D1),-1)]"":$ORDER(N(D1),-1),1:$ORDER(N(""),-1))
- +4 SET E2=D2
- +5 IF $DATA(N(E1,E2))[0
- SET E2=$SELECT($ORDER(N(E1,E2),-1)]"":$ORDER(N(E1,E2),-1),1:$ORDER(N(E1,E2)))
- +6 IF E1]""
- IF E2]""
- Begin DoDot:1
- +7 NEW RBO
- +8 SET RBO=$PIECE(N(E1,E2),",",3)
- +9 IF RBO
- IF $DATA(RNAV(RBO,E1))#2
- Begin DoDot:2
- +10 SET E2=""
- FOR
- SET E2=$ORDER(RNAV(RBO,E1,E2))
- IF E2=""
- QUIT
- IF RNAV(RBO,E1,E2)'[","
- QUIT
- End DoDot:2
- IF E2=""
- QUIT
- +11 SET $PIECE(LN,U)=$PIECE(N(E1,E2),",",1,2)
- End DoDot:1
- +12 ;
- +13 SET E1=$SELECT($ORDER(N(D1))]"":$ORDER(N(D1)),1:$ORDER(N("")))
- +14 SET E2=D2
- +15 IF $DATA(N(E1,E2))[0
- SET E2=$SELECT($ORDER(N(E1,E2),-1)]"":$ORDER(N(E1,E2),-1),1:$ORDER(N(E1,E2)))
- +16 IF E1]""
- IF E2]""
- Begin DoDot:1
- +17 NEW RBO
- +18 SET RBO=$PIECE(N(E1,E2),",",3)
- +19 IF RBO
- IF $DATA(RNAV(RBO,E1))#2
- Begin DoDot:2
- +20 SET E2=""
- FOR
- SET E2=$ORDER(RNAV(RBO,E1,E2))
- IF E2=""
- QUIT
- IF RNAV(RBO,E1,E2)'[","
- QUIT
- End DoDot:2
- IF E2=""
- QUIT
- +21 SET $PIECE(LN,U,2)=$PIECE(N(E1,E2),",",1,2)
- End DoDot:1
- +22 ;
- +23 SET E1=D1
- SET E2=$ORDER(N(D1,D2))
- +24 IF E2=""
- SET E1=$SELECT($ORDER(N(E1))]"":$ORDER(N(E1)),1:$ORDER(N("")))
- SET E2=$ORDER(N(E1,""))
- +25 IF E1]""
- IF E2]""
- SET $PIECE(LN,U,3)=$PIECE(N(E1,E2),",",1,2)
- +26 ;
- +27 SET E1=D1
- SET E2=$SELECT($ORDER(N(E1,D2),-1)]"":$ORDER(N(E1,D2),-1),1:"")
- +28 IF E2=""
- SET E1=$SELECT($ORDER(N(E1),-1)]"":$ORDER(N(E1),-1),1:$ORDER(N(""),-1))
- SET E2=$SELECT($ORDER(N(E1,""),-1)]"":$ORDER(N(E1,""),-1),1:"")
- +29 IF E1]""
- IF E2]""
- SET $PIECE(LN,U,4)=$PIECE(N(E1,E2),",",1,2)
- +30 ;
- +31 FOR I=1:1:4
- IF $PIECE($PIECE(LN,U,I),",",2)=B!'$PIECE($PIECE(LN,U,I),",",2)
- SET $PIECE(LN,U,I)=+$PIECE(LN,U,I)
- +32 QUIT
- +33 ;
- ORD(O) ;Setup field order info
- +1 NEW B,BO,BP,F,FO,FP
- +2 SET (BO,FO)=""
- FOR
- SET BO=$ORDER(O(BO))
- IF BO=""
- QUIT
- SET FO=$ORDER(O(BO,""))
- IF FO]""
- QUIT
- +3 IF FO=""
- SET BO=$ORDER(O(""))
- +4 SET B=+$GET(O(+BO))
- SET F=+$GET(O(+BO,+FO))
- +5 SET @DDSREFS@(DDSPG,"FIRST")=F_","_B
- +6 ;
- +7 SET (BP,FP)=0
- +8 SET BO=""
- FOR
- SET BO=$ORDER(O(BO))
- IF BO=""
- QUIT
- Begin DoDot:1
- +9 SET B=+O(BO)
- SET F=0
- +10 SET FO=$ORDER(O(BO,""))
- IF FO]""
- SET F=O(BO,FO)
- +11 SET $PIECE(@DDSREFS@(DDSPG,B),U,9)=F
- +12 IF $PIECE(O(BO),U,2)]""
- SET $PIECE(@DDSREFS@(DDSPG,B),U,10)=$SELECT($PIECE(O(BO),U,2)="FIRST":F,1:$PIECE(O(BO),U,2))
- +13 SET FO=""
- FOR
- SET FO=$ORDER(O(BO,FO))
- IF FO=""
- QUIT
- Begin DoDot:2
- +14 SET F=O(BO,FO)
- +15 SET $PIECE(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=F_$SELECT(B'=BP:","_B,1:"")
- +16 SET FP=F
- SET BP=B
- End DoDot:2
- End DoDot:1
- +17 SET $PIECE(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=0
- +18 QUIT
- +19 ;
- RNAV(DDSRNAV,DDSO) ;Setup nav and fo info for rep blocks
- +1 NEW DDSBO,DDSN,B,D1,D2,DN,F,F1,FO,LN,NX,RT
- +2 SET DDSBO=""
- FOR
- SET DDSBO=$ORDER(DDSRNAV(DDSBO))
- IF DDSBO=""
- QUIT
- Begin DoDot:1
- +3 ;N %X,%Y K DDSN S %X="DDSRNAV("_DDSBO_",",%Y="DDSN(" D %XY^%RCR
- +4 KILL DDSN
- MERGE DDSN=DDSRNAV(DDSBO)
- +5 SET D1=""
- FOR
- SET D1=$ORDER(DDSN(D1))
- IF D1=""
- QUIT
- IF $DATA(DDSN(D1))#2
- Begin DoDot:2
- +6 SET B=DDSN(D1)
- +7 SET D2=""
- FOR
- SET D2=$ORDER(DDSN(D1,D2))
- IF D2=""
- QUIT
- Begin DoDot:3
- +8 SET F=DDSN(D1,D2)
- SET LN=""
- IF F[","
- QUIT
- +9 DO NAV1(.DDSN,.DDSRNAV,D1,D2,.LN)
- +10 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,6,9)=LN
- End DoDot:3
- End DoDot:2
- +11 ;
- +12 SET B=+$GET(DDSO(+DDSBO))
- IF 'B
- QUIT
- +13 SET FO=$ORDER(DDSO(DDSBO,""))
- IF FO=""
- QUIT
- +14 SET (F,F1)=DDSO(DDSBO,FO)
- +15 FOR
- SET FO=$ORDER(DDSO(DDSBO,FO))
- IF FO=""
- QUIT
- Begin DoDot:2
- +16 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,10)=DDSO(DDSBO,FO)
- +17 SET F=DDSO(DDSBO,FO)
- End DoDot:2
- +18 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,10)=F1_",+1"
- +19 ;
- +20 SET DN=0
- +21 SET F=0
- FOR
- SET F=$ORDER(@DDSREFS@(DDSPG,B,F))
- IF DN=2!(F="")
- QUIT
- Begin DoDot:2
- +22 SET LN=$GET(@DDSREFS@(DDSPG,B,F,"N"))
- IF LN=""
- QUIT
- +23 SET RT=$PIECE(LN,U,3)
- SET NX=$PIECE(LN,U,5)
- +24 IF RT[","!'RT
- SET DN=DN+1
- +25 IF NX[","!'NX
- SET DN=DN+1
- End DoDot:2
- +26 ;
- +27 SET F=0
- FOR
- SET F=$ORDER(@DDSREFS@(DDSPG,B,F))
- IF F=""
- QUIT
- Begin DoDot:2
- +28 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,3)=RT
- +29 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,5)=NX
- End DoDot:2
- End DoDot:1
- +30 QUIT
