DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;21JAN2004
;;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.
;
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
. 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)
.. N HITE S HITE=$$HITE^DDSR(B)
.. 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
... Q:HITE<2 ;GFT
FIRST ...S FO=$O(DDSO(DDSBO,"")) S:FO FO=DDSO(DDSBO,FO)
...S F1=$O(DDSO(DDSBO,""),-1) S:F1 F1=DDSO(DDSBO,F1)
... I $P(@DDSREFS@(DDSPG,B,F,"N"),U,9)["-" S $P(^("N"),U,9)=$P(^("N"),U,4) I $P(^("N"),U,4)[","!'$P(^("N"),U,4) S $P(^("N"),U,9)=F1_",-1" ;WHERE 'F4' GOES
... I $P(^("N"),U,8)["+" S $P(^("N"),U,8)=$P(^("N"),U,3) I '$P(^("N"),U,3) S $P(^("N"),U,8)=FO_",+1" ;WHERE 'TAB' GOES
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSZ2 4598 printed Oct 16, 2024@18:44:16 Page 2
DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;21JAN2004
+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 ;
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 KILL DDSN
MERGE DDSN=DDSRNAV(DDSBO)
+4 SET D1=""
FOR
SET D1=$ORDER(DDSN(D1))
if D1=""
QUIT
if $DATA(DDSN(D1))#2
Begin DoDot:2
+5 SET B=DDSN(D1)
+6 NEW HITE
SET HITE=$$HITE^DDSR(B)
+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
+11 ;GFT
if HITE<2
QUIT
FIRST SET FO=$ORDER(DDSO(DDSBO,""))
if FO
SET FO=DDSO(DDSBO,FO)
+1 SET F1=$ORDER(DDSO(DDSBO,""),-1)
if F1
SET F1=DDSO(DDSBO,F1)
+2 ;WHERE 'F4' GOES
IF $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,9)["-"
SET $PIECE(^("N"),U,9)=$PIECE(^("N"),U,4)
IF $PIECE(^("N"),U,4)[","!'$PIECE(^("N"),U,4)
SET $PIECE(^("N"),U,9)=F1_",-1"
+3 ;WHERE 'TAB' GOES
IF $PIECE(^("N"),U,8)["+"
SET $PIECE(^("N"),U,8)=$PIECE(^("N"),U,3)
IF '$PIECE(^("N"),U,3)
SET $PIECE(^("N"),U,8)=FO_",+1"
End DoDot:3
End DoDot:2
+4 SET B=+$GET(DDSO(+DDSBO))
if 'B
QUIT
+5 SET FO=$ORDER(DDSO(DDSBO,""))
if FO=""
QUIT
+6 SET (F,F1)=DDSO(DDSBO,FO)
+7 FOR
SET FO=$ORDER(DDSO(DDSBO,FO))
if FO=""
QUIT
Begin DoDot:2
+8 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,10)=DDSO(DDSBO,FO)
+9 SET F=DDSO(DDSBO,FO)
End DoDot:2
+10 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,10)=F1_",+1"
+11 ;
+12 SET DN=0
+13 SET F=0
FOR
SET F=$ORDER(@DDSREFS@(DDSPG,B,F))
if DN=2!(F="")
QUIT
Begin DoDot:2
+14 SET LN=$GET(@DDSREFS@(DDSPG,B,F,"N"))
if LN=""
QUIT
+15 SET RT=$PIECE(LN,U,3)
SET NX=$PIECE(LN,U,5)
+16 if RT[","!'RT
SET DN=DN+1
+17 if NX[","!'NX
SET DN=DN+1
End DoDot:2
+18 ;
+19 SET F=0
FOR
SET F=$ORDER(@DDSREFS@(DDSPG,B,F))
if F=""
QUIT
Begin DoDot:2
+20 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,3)=RT
+21 SET $PIECE(@DDSREFS@(DDSPG,B,F,"N"),U,5)=NX
End DoDot:2
End DoDot:1
+22 QUIT
