Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDS

DDS.m

Go to the documentation of this file.
  1. DDS ;SFISC/MLH,MKO - MAIN ROUTINE ;18MAR2017
  1. ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;GFT;**1003,1004,1028,1043,1045,1055,1057**
  1. ;
  1. N DIE,DX,DY,X,Y,DDSATOP
  1. I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
  1. ;
  1. D EN^DDS0(.DDSFILE,DR,.DA)
  1. I $G(DIERR) D:$G(DDSPARM)'["E" G END^DDS0
  1. . W !,$C(7)_$$EZBLD^DIALOG(3000)
  1. . D MSG^DIALOG("BW")
  1. . S DIMSG=""
  1. ;
  1. N DR
  1. X:$G(^DIST(.403,+DDS,11))'?."^" ^(11)
  1. F D PG Q:DDACT="Q"
  1. X:$G(^DIST(.403,+DDS,12))'?."^" ^(12)
  1. ;
  1. D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
  1. G END^DDS0
  1. ;
  1. PROC ;Main loop -- do all the PAGES
  1. F D PG Q:DDACT="Q"
  1. Q
  1. ;
  1. PG ;Load page
  1. N DDSMX,DDSMY,DDSMOUSE,FND
  1. S DDACT="N"
  1. D EN^DDS1(DDSPG)
  1. I $G(DIERR) D Q
  1. . N P S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
  1. . S:P(2)="" P(2)="unnamed"
  1. . D BLD^DIALOG(3041,.P),ERR^DDSMSG H 2
  1. . S DDACT="Q"
  1. ;
  1. ;Pre-action, save old and get next page
  1. S DDSOPB=DDSPG
  1. I $G(^DIST(.403,+DDS,40,DDSPG,11))'?."^" D PA(^(11)) Q:DDACT="NP"
  1. S DDSNP=$$NP^DDS5(.Y) S:'Y DDSNP=""
  1. ;
  1. ;Get DDO and DDSBK
  1. I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
  1. . S DDO=+$G(@DDSREFS@(DDSPG,"FIRST")),DDSBK=$P($G(^("FIRST")),",",2)
  1. I 'DDSBK D Q
  1. . D BLD^DIALOG(3055,"number "_$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U)_$S($G(^(1))]"":" ("_$P($G(^(1)),U)_")",1:""))
  1. . D ERR^DDSMSG H 2
  1. . S DDACT="Q"
  1. ;
  1. ;Get DDSPOP and update DDSSC array
  1. ;If we're going to another page
  1. I '$D(DDSPGUP) D
  1. . S DDSLN=^DIST(.403,+DDS,40,DDSPG,0),DDSPOP=$P(DDSLN,U,6)
  1. . K:'DDSPOP DDSSC
  1. SEL . I $D(DDSSEL) D
  1. .. N P S P=$P($G(^DIST(.403,+DDS,21)),U) Q:P="" Q:$O(^(40,"B",P,""))'=DDSPG ;CONVERT PAGE TO ITS INTERNAL NUMBER
  1. .. S DDSDASV=DDSDA,DDSDLSV=DDSDL
  1. .. M DDSORGSV=DDSDAORG
  1. .. K DA,@$$D0(DDSDL),DDSDAORG ;IF IT'S (REALLY) A RECORD SELECTION PAGE FORGET DA
  1. .. S (DA,D0,DDSDAORG)="",DDSDA="0,",DDSDL=0
  1. . I '$D(DDSSC("B",DDSPG)) D
  1. .. S DDSSC=$G(DDSSC)+1,DDSSC(DDSSC)=DDSPG,DDSSC("B",DDSPG,DDSSC)="" ;Stack DDSSC
  1. .. S:DDSPOP $P(DDSSC(DDSSC),U,2,3)=$P(DDSLN,U,3)_U_$P(DDSLN,U,7)
  1. .. I $G(DDSSTK) S $P(DDSSC(DDSSC),U,4)=1 K DDSSTK
  1. .. K DDSPOP
  1. . E D
  1. .. Q:$P($G(DDSSC(+$G(DDSSC))),U)=DDSPG
  1. .. N I,J,S
  1. .. S I=$O(DDSSC("B",DDSPG,"")),S=DDSSC(I) K DDSSC("B",DDSPG,I)
  1. .. F J=I:1:DDSSC-1 D
  1. ... K DDSSC("B",$P(DDSSC(J+1),U),J)
  1. ... S DDSSC(J)=DDSSC(J+1),DDSSC("B",$P(DDSSC(J),U),J)=""
  1. .. S DDSSC(DDSSC)=S,DDSSC("B",DDSPG,DDSSC)=""
  1. ;
  1. ;If we've moving up from a pop-up page
  1. E K DDSPGUP
  1. ;
  1. ;Paint the page
  1. D RP^DDSR(DDSSC(DDSSC),DDSSC=1)
  1. ;
  1. P1 F D BLK Q:"^Q^NP^"[(U_DDACT_U)
  1. ;
  1. ;PAGE Post action, print any help
  1. D:$G(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^" PA(^(12))
  1. D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
  1. G:"^NB^N^"[(U_DDACT_U) P1
  1. ;
  1. I DDACT="Q" D
  1. . I '$P(DDSSC(DDSSC),U,4) D
  1. .. I $G(DDSSEL) D GDA^DDSRSEL Q:'DA ;Process what came from the RECORD SELECTION PAGE now that we've returned from it
  1. .. D:$G(DDSSC)>1 CLEAR^DDSBOX($P(DDSSC(DDSSC),U,2),$P(DDSSC(DDSSC),U,3))
  1. .. S:DDSSC>1 DDSPG=$P(DDSSC(DDSSC-1),U),DDACT="N",DDSPGUP=1
  1. . K DDSSC("B",$P(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC) S DDSSC=DDSSC-1 ;Unstack DDSSC
  1. Q
  1. ;
  1. BLK S DDACT="N",DDSOSV=0
  1. ;
  1. I $D(@DDSREFS@(DDSPG,DDSBK))[0 S DDACT="Q" Q
  1. S DDSLN=@DDSREFS@(DDSPG,DDSBK)
  1. ;
  1. S DDSDN=$P(DDSLN,U,4),DDSTP=$P(DDSLN,U,5)
  1. S DDSREP=$P(DDSLN,U,7),DDSPTB=$P(DDSLN,U,8)
  1. K:'DDSDN DDSDN K:DDSTP="e" DDSTP K:'DDSPTB DDSPTB K:DDSREP'>1 DDSREP
  1. ;
  1. I $D(DDSPTB)!$D(DDSREP) N DDP,DDSDA,DIE D ;NEW WHEN WE GO INTO MULTIPLE!!
  1. . S DDP=$P(DDSLN,U,3)
  1. DIE . S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) I DDSDA'>0,$G(^(DDSBK,"COMP MUL"))="" S DIE=$G(DIE) Q ;Get Entry Number
  1. . S DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL")
  1. ;
  1. I $D(DDSPTB) N DA,@$$D0(DDSDL),DDSDL D
  1. . S DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB")
  1. . S DDSDL=$L(DDSDA,",")-2
  1. . S (D0,DA)=+DDSDA
  1. ;
  1. I $D(DDSREP) N DDSDL,DA D
  1. . S DDSREP=$P(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999)
  1. . S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),$P(DDSREP,U,4)),"0,"_DDSDA) ;2-arg $G -- go to empty line if none other specified
  1. . S:'$P(DDSREP,U,7) DDSDA=$P(DDSDA,",")_","
  1. . S DDSDL=$L(DDSDA,",")-2
  1. I N @$$D0(DDSDL) D
  1. . D BLDDA(DDSDA)
  1. . S:'DA DDO=+$P(DDSREP,U,8) ;If this is a new subEntry, start at 1st editable field
  1. ;
  1. PTB I $D(DDSPTB),'$D(DDSREP),'DDSDA,DDSDAORG D Q
  1. . N DDSBK0
  1. . S DDSBK0=DDSBK
  1. . F S DDSBK=$$NB^DDS5(.Y) Q:DDSBK=DDSBK0!'Y!$G(@DDSREFT@(DDSPG,DDSBK))
  1. . Q:Y
  1. . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" Q
  1. . S DDSPG=$$PP^DDS5(.Y) I Y S DDACT="NP" Q
  1. . S DDACT="Q"
  1. ;
  1. S $P(DDSOPB,U,2)=DDSBK
  1. I $G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
  1. I $G(^DIST(.404,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
  1. 1 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
  1. . S DDO=$P(@DDSREFS@(DDSPG,DDSBK),U,9) ;First field
  1. K DDSLN
  1. ;
  1. B1 D ^DDS01
  1. ;
  1. I $G(^DIST(.403,+DDS,40,DDSPG,40,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
  1. I $G(^DIST(.404,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
  1. Q
  1. ;
  1. BLDDA(DDSDA) ;
  1. N I
  1. S (DA,@("D"_DDSDL))=$P(DDSDA,",")
  1. F I=1:1:DDSDL S (DA(I),@("D"_(DDSDL-I)))=$P(DDSDA,",",I+1)
  1. Q
  1. ;
  1. D0(DL) ;Given DL, return string D0,D1,...,Dn
  1. N I,S
  1. S S="" F I=0:1:DL S S=S_"D"_I_","
  1. S:S?.E1"," S=$E(S,1,$L(S)-1)
  1. Q S
  1. ;
  1. CLRMSG ;FROM DDSU
  1. I $G(DDSKM) H 2 K DDSKM ;GFT ** IF WE WERE KEEPING SOMETHING IN HELP AREA, HOLD UP 2 SECONDS ISB-0603-31054
  1. K DDQ S DDSH=1,(DDM,DX)=0,DY=DDSHBX+1 X DDXY W $P(DDGLCLR,DDGLDEL,3) ;CLEAR WHOLE COMMAND AREA
  1. N I F S I=$O(DDSMOUSE(DDSHBX)) Q:I+1=IOSL!'I K DDSMOUSE(I)
  1. Q
  1. ;
  1. PA(DDSPA) ;
  1. N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR
  1. K DDSBR X DDSPA ;PRE-ACTION OR POST-ACTION
  1. I $D(DDSBR)[0 S:$D(DDSBRORG)#2 DDSBR=DDSBRORG Q
  1. D BR^DDS2
  1. Q
  1. ;
  1. ;
  1. ;
  1. ;
  1. ;
  1. ;
  1. RESET ;Programmer entry point to reset terminal and cleanup
  1. D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW")
  1. W $P($G(DDGLVID),DDGLDEL,10)
  1. K DDSPARM
  1. S DDSREFT="^TMP(""DDS"",$J)"
  1. D END^DDS0
  1. G RESET^DDGF
  1. ;
  1. RUN ;Run a form
  1. G ^DDSRUN
  1. CLONE ;Clone a form
  1. G ^DDSCLONE
  1. PRINT ;Print a form
  1. G ^DDSPRNT
  1. DFRM ;Delete a form
  1. G ^DDSDFRM
  1. DBLK ;Delete unused blocks
  1. G ^DDSDBLK