DDSM ;SFISC/MKO-MULTILINE ;10:12 AM 1 Oct 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.
MNAV(FND) ;Navigate within repeating blocks
;Returns FND if navigating to another field within the repeating
;block
N DDSCL,DDSDDO,DDSNR,DDSPDA,DDSSN,DDSSTL
S DDSDDO=$P(DDSU("N"),U,$L($P("U^D^R^L^N",DDACT),U)+5)
;
S DDSPDA=$P(DDSREP,U),DDSSTL=$P(DDSREP,U,2),DDSCL=$P(DDSREP,U,3)
S DDSSN=$P(DDSREP,U,4),DDSNR=$P(DDSREP,U,5)
;
I $P(DDSDDO,",",2)="-1" D MUP Q
I $P(DDSDDO,",",2)="+1" D MDN Q
I DA S DDO=+DDSDDO,FND=1 Q
Q
;
MUP ;Move up a line
Q:DDSSN'>1
S DDSSN=DDSSN-1
I DDSCL>1 D
. S DDSCL=DDSCL-1 D MDA
E D
. S DDSSTL=DDSSTL-1
. D MDA,DB^DDSR(DDSPG,DDSBK)
Q
;
MDN ;Move down a line
Q:'DA
S DDSSN=DDSSN+1
I DDSCL<DDSNR D
. S DDSCL=DDSCL+1 D MDA
E D
. S DDSSTL=DDSSTL+1
. D MDA,DB^DDSR(DDSPG,DDSBK)
Q
;
MDA ;Update DDO, DA and Dn, set FND=1
N DDSDASV
S $P(DDSREP,U,2,4)=DDSSTL_U_DDSCL_U_DDSSN
S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
S DDSDASV=DDSDA
S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$P(DDSDA,",",2,999))
S DA=+DDSDA,@("D"_DDSDL)=DA
S DDO=$S(DA:+DDSDDO,1:$P(DDSREP,U,8))
S FND=1
Q
;
SEL ;Issue read
N DIRUT
S DIR(0)="PO"_DIE_":QEMZ"_$E("L",'$D(DDSTP)&'$P(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,2),U,4))_$E("V",$P(^(2),U,6))
I $P(DDSREP,U,7) D
. N DDSMSPEC S DDSMSPEC=$P(^DD($P(DDSREP,U,6),$P(DDSREP,U,7),0),U,2)
. I $D(@(DIE_"0)"))[0 S ^(0)=U_DDSMSPEC_U_U
. E I $P(@(DIE_"0)"),U,2)'=DDSMSPEC S $P(^(0),U,2)=DDSMSPEC
. I $P(DDSREP,U,9)]"" D
.. N DDSROOT,DDSSUB
.. S DDSROOT=$NA(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),"B"))
.. S DDSSUB="Y_"",""_"""_$P(DDSREP,U)_""""
.. S DDSROOT=$E(DDSROOT,1,$L(DDSROOT)-1)_","_DDSSUB_")"
.. S DIR("S")="I $D("_DDSROOT_")"
E N DDSLASCN D
. S DDSLASCN=$NA(@(DIE_""""_$P(DDSREP,U,9)_""","_+$P(DDSREP,U)_")"))
. S DIR("S")="X ""I 0"" N R,S S (R,S)=DDSLASCN F S R=$Q(@R) Q:R=""""!($NA(@R,"_$QL(DDSLASCN)_")'=S) I $QS(R,$QL(R))=Y Q"
D ^DIR K DIR,DUOUT,DIROUT Q:DIR0N!$D(DIRUT)
;
S DA=+Y,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA
I $P(Y,U,3)=1 D
. N DDSFN,DDSLN,DDSPDA,DDSSN
. S DDSPDA=$P(DDSREP,U),DDSLN=$P(DDSREP,U,3),DDSSN=$P(DDSREP,U,4)
. S DDSFN=+$P(@DDSREFS@(DDSPG,DDSBK),U,3)
. ;
. I '$P(DDSREP,U,7) D
.. N DR,X,Y
.. S DR=$O(^DD(DDSFN,0,"IX",$P(DDSREP,U,9),DDSFN,""))_"////"_+DDSREP
.. D ^DIE
. ;
. D ADD(DDSDA,DDSPDA,DDSSN)
. S DDSFN="F"_DDSFN
. D DMULT1^DDSR(DDSPG,DDSBK,DDSFN,DDSDA,DDSLN,DDSSN)
. S DDSCHKQ=2
E D
. S DDSCHKQ=1
. D POSDA(DDSDA)
;
S Y=$P(Y,U)
S:X="" Y=""
Q
;
END ;
S DDACT="N"
Q:'DA
D POSSN(999999999999)
Q
;
PGDN ;Page down
S DDACT="N"
I 'DA D
. I DDSNP]"" S DDSPG=DDSNP,DDACT="NP"
E D POSSN($P(DDSREP,U,2)+$P(DDSREP,U,5))
Q
;
PGUP ;Page up
S DDACT="N"
I $P(DDSREP,U,4)=1 D
. S DDSPG=$$PP^DDS5(.Y)
. S:Y=1 DDACT="NP"
E D POSSN($P(DDSREP,U,2)-$P(DDSREP,U,5))
Q
;
POSSN(DDSSN,DDSPAINT) ;Make line with given DDSSN current
N DDSLSN,DDSPDA,DDSSTL
S DDSPDA=$P(DDSREP,U)
S DDSSTL=$P(DDSREP,U,2)
;
S DDSLSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1)+1
S DDSSN=$$MIN(DDSLSN,DDSSN)
S:DDSSN<1 DDSSN=1
;
S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$P(DDSDA,",",2,999))
S DA=+DDSDA,@("D"_DDSDL)=DA
;
S:'DA DDO=$P(DDSREP,U,8)
I DDSSN'<DDSSTL,DDSSN<(DDSSTL+$P(DDSREP,U,5)) D
. S $P(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
. S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
. D:$G(DDSPAINT) DB^DDSR(DDSPG,DDSBK)
E D
. S DDSSTL=$$MIN(DDSLSN-$P(DDSREP,U,5)+1,DDSSN)
. S:DDSSTL<1 DDSSTL=1
. S $P(DDSREP,U,2,4)=DDSSTL_U_(DDSSN-DDSSTL+1)_U_DDSSN
. S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
. D DB^DDSR(DDSPG,DDSBK)
Q
;
POSDA(DDSDA) ;Make line with given DDSDA current
N DDSPDA,DDSSN,DDSSTL
S DDSSN=@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),"B",DDSDA)
S DDSPDA=$P(DDSREP,U),DDSSTL=$P(DDSREP,U,2)
;
I DDSSN'<DDSSTL,DDSSN<(DDSSTL+$P(DDSREP,U,5)) D
. N DY,DX
. S $P(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
. S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
. S DY=$P(DIR0,U),DX=$P(DIR0,U,2) X IOXY W $J("",$P(DIR0,U,3))
E D
. S $P(DDSREP,U,2,4)=DDSSN_"^1^"_DDSSN
. S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
. D DB^DDSR(DDSPG,DDSBK)
Q
;
ADD(DDSDA,DDSPDA,DDSSN) ;Add entry
S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)=DDSSN
S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIE
S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSDA
D ^DDS11(DDSBK)
S DDSCHG=1
Q
;
MIN(X,Y) ;
Q $S(X<Y:X,1:Y)
MAX(X,Y) ;
Q $S(X>Y:X,1:Y)
DDSM ;SFISC/MKO-MULTILINE ;10:12 AM 1 Oct 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.
MNAV(FND) ;Navigate within repeating blocks
+1 ;Returns FND if navigating to another field within the repeating
+2 ;block
+3 NEW DDSCL,DDSDDO,DDSNR,DDSPDA,DDSSN,DDSSTL
+4 SET DDSDDO=$PIECE(DDSU("N"),U,$LENGTH($PIECE("U^D^R^L^N",DDACT),U)+5)
+5 ;
+6 SET DDSPDA=$PIECE(DDSREP,U)
SET DDSSTL=$PIECE(DDSREP,U,2)
SET DDSCL=$PIECE(DDSREP,U,3)
+7 SET DDSSN=$PIECE(DDSREP,U,4)
SET DDSNR=$PIECE(DDSREP,U,5)
+8 ;
+9 IF $PIECE(DDSDDO,",",2)="-1"
DO MUP
QUIT
+10 IF $PIECE(DDSDDO,",",2)="+1"
DO MDN
QUIT
+11 IF DA
SET DDO=+DDSDDO
SET FND=1
QUIT
+12 QUIT
+13 ;
MUP ;Move up a line
+1 IF DDSSN'>1
QUIT
+2 SET DDSSN=DDSSN-1
+3 IF DDSCL>1
Begin DoDot:1
+4 SET DDSCL=DDSCL-1
DO MDA
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET DDSSTL=DDSSTL-1
+7 DO MDA
DO DB^DDSR(DDSPG,DDSBK)
End DoDot:1
+8 QUIT
+9 ;
MDN ;Move down a line
+1 IF 'DA
QUIT
+2 SET DDSSN=DDSSN+1
+3 IF DDSCL<DDSNR
Begin DoDot:1
+4 SET DDSCL=DDSCL+1
DO MDA
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET DDSSTL=DDSSTL+1
+7 DO MDA
DO DB^DDSR(DDSPG,DDSBK)
End DoDot:1
+8 QUIT
+9 ;
MDA ;Update DDO, DA and Dn, set FND=1
+1 NEW DDSDASV
+2 SET $PIECE(DDSREP,U,2,4)=DDSSTL_U_DDSCL_U_DDSSN
+3 SET $PIECE(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
+4 SET DDSDASV=DDSDA
+5 SET DDSDA=$GET(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$PIECE(DDSDA,",",2,999))
+6 SET DA=+DDSDA
SET @("D"_DDSDL)=DA
+7 SET DDO=$SELECT(DA:+DDSDDO,1:$PIECE(DDSREP,U,8))
+8 SET FND=1
+9 QUIT
+10 ;
SEL ;Issue read
+1 NEW DIRUT
+2 SET DIR(0)="PO"_DIE_":QEMZ"_$EXTRACT("L",'$DATA(DDSTP)&'$PIECE(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,2),U,4))_$EXTRACT("V",$PIECE(^(2),U,6))
+3 IF $PIECE(DDSREP,U,7)
Begin DoDot:1
+4 NEW DDSMSPEC
SET DDSMSPEC=$PIECE(^DD($PIECE(DDSREP,U,6),$PIECE(DDSREP,U,7),0),U,2)
+5 IF $DATA(@(DIE_"0)"))[0
SET ^(0)=U_DDSMSPEC_U_U
+6 IF '$TEST
IF $PIECE(@(DIE_"0)"),U,2)'=DDSMSPEC
SET $PIECE(^(0),U,2)=DDSMSPEC
+7 IF $PIECE(DDSREP,U,9)]""
Begin DoDot:2
+8 NEW DDSROOT,DDSSUB
+9 SET DDSROOT=$NAME(@DDSREFT@(DDSPG,DDSBK,$PIECE(DDSREP,U),"B"))
+10 SET DDSSUB="Y_"",""_"""_$PIECE(DDSREP,U)_""""
+11 SET DDSROOT=$EXTRACT(DDSROOT,1,$LENGTH(DDSROOT)-1)_","_DDSSUB_")"
+12 SET DIR("S")="I $D("_DDSROOT_")"
End DoDot:2
End DoDot:1
+13 IF '$TEST
NEW DDSLASCN
Begin DoDot:1
+14 SET DDSLASCN=$NAME(@(DIE_""""_$PIECE(DDSREP,U,9)_""","_+$PIECE(DDSREP,U)_")"))
+15 SET DIR("S")="X ""I 0"" N R,S S (R,S)=DDSLASCN F S R=$Q(@R) Q:R=""""!($NA(@R,"_$QLENGTH(DDSLASCN)_")'=S) I $QS(R,$QL(R))=Y Q"
End DoDot:1
+16 DO ^DIR
KILL DIR,DUOUT,DIROUT
IF DIR0N!$DATA(DIRUT)
QUIT
+17 ;
+18 SET DA=+Y
SET $PIECE(DDSDA,",")=DA
SET @("D"_DDSDL)=DA
+19 IF $PIECE(Y,U,3)=1
Begin DoDot:1
+20 NEW DDSFN,DDSLN,DDSPDA,DDSSN
+21 SET DDSPDA=$PIECE(DDSREP,U)
SET DDSLN=$PIECE(DDSREP,U,3)
SET DDSSN=$PIECE(DDSREP,U,4)
+22 SET DDSFN=+$PIECE(@DDSREFS@(DDSPG,DDSBK),U,3)
+23 ;
+24 IF '$PIECE(DDSREP,U,7)
Begin DoDot:2
+25 NEW DR,X,Y
+26 SET DR=$ORDER(^DD(DDSFN,0,"IX",$PIECE(DDSREP,U,9),DDSFN,""))_"////"_+DDSREP
+27 DO ^DIE
End DoDot:2
+28 ;
+29 DO ADD(DDSDA,DDSPDA,DDSSN)
+30 SET DDSFN="F"_DDSFN
+31 DO DMULT1^DDSR(DDSPG,DDSBK,DDSFN,DDSDA,DDSLN,DDSSN)
+32 SET DDSCHKQ=2
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 SET DDSCHKQ=1
+35 DO POSDA(DDSDA)
End DoDot:1
+36 ;
+37 SET Y=$PIECE(Y,U)
+38 IF X=""
SET Y=""
+39 QUIT
+40 ;
END ;
+1 SET DDACT="N"
+2 IF 'DA
QUIT
+3 DO POSSN(999999999999)
+4 QUIT
+5 ;
PGDN ;Page down
+1 SET DDACT="N"
+2 IF 'DA
Begin DoDot:1
+3 IF DDSNP]""
SET DDSPG=DDSNP
SET DDACT="NP"
End DoDot:1
+4 IF '$TEST
DO POSSN($PIECE(DDSREP,U,2)+$PIECE(DDSREP,U,5))
+5 QUIT
+6 ;
PGUP ;Page up
+1 SET DDACT="N"
+2 IF $PIECE(DDSREP,U,4)=1
Begin DoDot:1
+3 SET DDSPG=$$PP^DDS5(.Y)
+4 IF Y=1
SET DDACT="NP"
End DoDot:1
+5 IF '$TEST
DO POSSN($PIECE(DDSREP,U,2)-$PIECE(DDSREP,U,5))
+6 QUIT
+7 ;
POSSN(DDSSN,DDSPAINT) ;Make line with given DDSSN current
+1 NEW DDSLSN,DDSPDA,DDSSTL
+2 SET DDSPDA=$PIECE(DDSREP,U)
+3 SET DDSSTL=$PIECE(DDSREP,U,2)
+4 ;
+5 SET DDSLSN=$ORDER(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1)+1
+6 SET DDSSN=$$MIN(DDSLSN,DDSSN)
+7 IF DDSSN<1
SET DDSSN=1
+8 ;
+9 SET DDSDA=$GET(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$PIECE(DDSDA,",",2,999))
+10 SET DA=+DDSDA
SET @("D"_DDSDL)=DA
+11 ;
+12 IF 'DA
SET DDO=$PIECE(DDSREP,U,8)
+13 IF DDSSN'<DDSSTL
IF DDSSN<(DDSSTL+$PIECE(DDSREP,U,5))
Begin DoDot:1
+14 SET $PIECE(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
+15 SET $PIECE(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
+16 IF $GET(DDSPAINT)
DO DB^DDSR(DDSPG,DDSBK)
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET DDSSTL=$$MIN(DDSLSN-$PIECE(DDSREP,U,5)+1,DDSSN)
+19 IF DDSSTL<1
SET DDSSTL=1
+20 SET $PIECE(DDSREP,U,2,4)=DDSSTL_U_(DDSSN-DDSSTL+1)_U_DDSSN
+21 SET $PIECE(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
+22 DO DB^DDSR(DDSPG,DDSBK)
End DoDot:1
+23 QUIT
+24 ;
POSDA(DDSDA) ;Make line with given DDSDA current
+1 NEW DDSPDA,DDSSN,DDSSTL
+2 SET DDSSN=@DDSREFT@(DDSPG,DDSBK,$PIECE(DDSREP,U),"B",DDSDA)
+3 SET DDSPDA=$PIECE(DDSREP,U)
SET DDSSTL=$PIECE(DDSREP,U,2)
+4 ;
+5 IF DDSSN'<DDSSTL
IF DDSSN<(DDSSTL+$PIECE(DDSREP,U,5))
Begin DoDot:1
+6 NEW DY,DX
+7 SET $PIECE(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
+8 SET $PIECE(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
+9 SET DY=$PIECE(DIR0,U)
SET DX=$PIECE(DIR0,U,2)
XECUTE IOXY
WRITE $JUSTIFY("",$PIECE(DIR0,U,3))
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET $PIECE(DDSREP,U,2,4)=DDSSN_"^1^"_DDSSN
+12 SET $PIECE(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
+13 DO DB^DDSR(DDSPG,DDSBK)
End DoDot:1
+14 QUIT
+15 ;
ADD(DDSDA,DDSPDA,DDSSN) ;Add entry
+1 SET @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)=DDSSN
+2 SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
SET ^("ADD",^("ADD"))=DDSDA_DIE
+3 SET @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSDA
+4 DO ^DDS11(DDSBK)
+5 SET DDSCHG=1
+6 QUIT
+7 ;
MIN(X,Y) ;
+1 QUIT $SELECT(X<Y:X,1:Y)
MAX(X,Y) ;
+1 QUIT $SELECT(X>Y:X,1:Y)
