DDSM ;SFISC/MKO-MULTILINE ;2015-01-02 5:52 PM
;;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.
;
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 ;ADD ONE TO WHAT THE TOP LINE NUMBER IS NOW
. 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 ;Multiple Field
. 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_")"
GFT E I $G(@DDSREFT@(DDSPG,DDSBK,"COMP MUL")) D
.S DIR("S")="I +$O(@DDSREFT@(""F"_^("COMP MUL")_""",+Y_""+""))=+Y"
E N DDSLASCN D ;Backwards pointer
. 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 ;We've added a new one
. 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)
. ;
STUFF .I '$P(DDSREP,U,7),DDSREP>0,'$G(@DDSREFT@(DDSPG,DDSBK,"COMP MUL")) D ;If this is top level of a pointing file, stuff the pointer back to where we came from
.. N DR,X,Y
.. S Y=$P(DDSREP,U,9) Q:Y=""
.. S DR=$O(^DD(DDSFN,0,"IX",Y,DDSFN,""))_"////"_+DDSREP Q:'DR
.. 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) ;They have entered something already on the muliple display. Jump to it.
;
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,REWRITE) ;Make line with given DDSDA current REWRITE called from DDS01 if the line we read from is not empty
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
. S $P(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
. S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
. I $G(REWRITE)]"" X IOXY W $P(DDGLVID,DDGLDEL),$E(REWRITE,1,$P(DIR0,U,3)) Q
. N DX,DY S DY=$P(DIR0,U),DX=$P(DIR0,U,2) X IOXY W $J("",$P(DIR0,U,3)) ;CLEARS THE LINE WE JUST READ FROM
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 EN^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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSM 5483 printed Apr 09, 2024@21:54:55 Page 2
DDSM ;SFISC/MKO-MULTILINE ;2015-01-02 5:52 PM
+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 ;
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 ;ADD ONE TO WHAT THE TOP LINE NUMBER IS NOW
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 ;Multiple Field
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
GFT IF '$TEST
IF $GET(@DDSREFT@(DDSPG,DDSBK,"COMP MUL"))
Begin DoDot:1
+1 SET DIR("S")="I +$O(@DDSREFT@(""F"_^("COMP MUL")_""",+Y_""+""))=+Y"
End DoDot:1
+2 ;Backwards pointer
IF '$TEST
NEW DDSLASCN
Begin DoDot:1
+3 SET DDSLASCN=$NAME(@(DIE_""""_$PIECE(DDSREP,U,9)_""","_+$PIECE(DDSREP,U)_")"))
+4 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
+5 DO ^DIR
KILL DIR,DUOUT,DIROUT
if DIR0N!$DATA(DIRUT)
QUIT
+6 ;
+7 SET DA=+Y
SET $PIECE(DDSDA,",")=DA
SET @("D"_DDSDL)=DA
+8 ;We've added a new one
IF $PIECE(Y,U,3)=1
Begin DoDot:1
+9 NEW DDSFN,DDSLN,DDSPDA,DDSSN
+10 SET DDSPDA=$PIECE(DDSREP,U)
SET DDSLN=$PIECE(DDSREP,U,3)
SET DDSSN=$PIECE(DDSREP,U,4)
+11 SET DDSFN=+$PIECE(@DDSREFS@(DDSPG,DDSBK),U,3)
+12 ;
STUFF ;If this is top level of a pointing file, stuff the pointer back to where we came from
IF '$PIECE(DDSREP,U,7)
IF DDSREP>0
IF '$GET(@DDSREFT@(DDSPG,DDSBK,"COMP MUL"))
Begin DoDot:2
+1 NEW DR,X,Y
+2 SET Y=$PIECE(DDSREP,U,9)
if Y=""
QUIT
+3 SET DR=$ORDER(^DD(DDSFN,0,"IX",Y,DDSFN,""))_"////"_+DDSREP
if 'DR
QUIT
+4 DO ^DIE
End DoDot:2
+5 ;
+6 DO ADD(DDSDA,DDSPDA,DDSSN)
+7 SET DDSFN="F"_DDSFN
+8 DO DMULT1^DDSR(DDSPG,DDSBK,DDSFN,DDSDA,DDSLN,DDSSN)
+9 SET DDSCHKQ=2
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET DDSCHKQ=1
+12 ;They have entered something already on the muliple display. Jump to it.
DO POSDA(DDSDA)
End DoDot:1
+13 ;
+14 SET Y=$PIECE(Y,U)
+15 if X=""
SET Y=""
+16 QUIT
+17 ;
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,REWRITE) ;Make line with given DDSDA current REWRITE called from DDS01 if the line we read from is not empty
+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 SET $PIECE(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
+7 SET $PIECE(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
+8 IF $GET(REWRITE)]""
XECUTE IOXY
WRITE $PIECE(DDGLVID,DDGLDEL),$EXTRACT(REWRITE,1,$PIECE(DIR0,U,3))
QUIT
+9 ;CLEARS THE LINE WE JUST READ FROM
NEW DX,DY
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 EN^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)
