- DDSRSEL ;SFISC/MKO-RECORD SELECTION ;7JAN2004
- ;;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.
- ;
- PG ;Called from:
- ; DDS01 when user presses SELECT
- ; FIRSTPG^DDS0 if no DA was passed in.
- ;
- ;Returns (if there is a record selection page and we're not in
- ;a multiple)
- ; DDSPG = Record selection page #
- ; DDACT = "NP"
- ; DDSSEL = 1 (undefined if no record selection page)
- ;
- N P,P1 K DDSSEL
- I $D(DDSSC),$P($G(DDSSC(DDSSC)),U,4) Q ;GFT
- ;
- S P="",P1=$P($G(^DIST(.403,+DDS,21)),U)
- I P1]"" D
- . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
- . I P]"",$D(^DIST(.403,+DDS,40,P,0))[0 S P=""
- ;
- I P]"" D
- . I $G(DDO),$G(DDSDN)=1 D
- .. D ERR3^DDS3
- . E S DDSPG=P,DDACT="NP",DDSSEL=1
- Q
- ;
- GDA ;Called from DDS
- ;After a record selection page is closed get the DA from
- ;the first field on the page.
- N DDSANS,DDSREC,Y,PG
- S DDSANS=""
- GFT S PG=$P($G(^DIST(.403,+DDS,21)),U) G KILL:'PG N P S P=$O(^(40,"B",PG,0)) D:P I '$D(Y) G KILL
- .F Y=0:0 S Y=$O(^DIST(.403,+DDS,40,P,40,Y)) Q:'Y I $G(^(Y,"COMP MUL"))]"" K Y Q
- E S DDSREC=$$GET^DDSVALF(1,1,PG) ;ON THE OLD KIND OF LOOKUP PAGE, THERE IS 1 FIELD, 1 BLOCK
- ;
- K DA,DDSDAORG
- S DDSDA=DDSDASV,DDSDL=DDSDLSV
- D BLDDA^DDS(DDSDA)
- M DDSDAORG=DDSORGSV
- ;
- I 'DDSREC,DA S DDSREC=DA
- E I DDSREC,DDSREC'=DA D
- . I DA D Q:DDSREC=DA
- .. S DDSANS=$$ASKSAVE
- .. I DDSANS="R" S DDSREC=DA
- .. E I DDSANS="S" D
- ... D ^DDS4
- ... S:Y'=1 DDSREC=DA
- . ;
- . S DA=DDSREC
- . D REC^DDS0(DDP,.DA)
- . ;
- . I $G(DIERR) D Q
- .. D ERR^DDSMSG H 2
- .. S DA=+$G(DDSDASV),DDACT="N"
- .. D REC^DDS0(DDP,.DA)
- . ;
- . S DDACT="N"
- . I DDSSC=1 D FRSTPG^DDS0(DDS,.DA,$G(DDSPAGE))
- . D CLRDAT,UNLOCK
- ;
- KILL K DDSSEL,DDSDASV,DDSDASV,DDSDLSV,DDSORGSV
- Q
- ;
- ASKSAVE() ;
- ;Ask user whether to save the previous record
- N X,Y
- D:DDM CLRMSG^DDS
- S DDM=1
- ;
- K DIR S DIR(0)="SM^S:SAVE;D:DISCARD;R:RETURN"
- S DIR("A",1)=" NOTE: You must Save or Discard all edits to the"
- S DIR("A",2)=" previous record before editing the next record."
- S DIR("A",3)=" "
- S DIR("A")="Save, Discard, or Return (S/D/R)"
- S DIR("B")="SAVE"
- ;
- S DIR("?",1)="Enter 'S' to save or 'D' to discard."
- S DIR("?")="Enter 'R' or '^' to return to previous record."
- ;
- S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^7^"_(IOSL-4)_"^0"
- D ^DIR
- I $D(DIRUT) S Y="R"
- E I X="SAVE" S Y="S"
- K DIR,DIROUT,DIRUT,DTOUT,DUOUT
- Q Y
- ;
- CLRDAT ;Clear all data values from @DDSREFT
- N F,P
- S P=0 F S P=$O(@DDSREFT@(P)) Q:'P K @DDSREFT@(P)
- S F="F" F S F=$O(@DDSREFT@(F)) Q:$E(F)'="F" K @DDSREFT@(F)
- Q
- ;
- UNLOCK ;Unlock all records locked
- Q:'$D(^TMP("DDS",$J,"LOCK"))
- N I S I=""
- F S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I="" D
- . I I'=(DIE_DA_")") L -@I K ^TMP("DDS",$J,"LOCK",I)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSRSEL 3008 printed Mar 13, 2025@21:48:16 Page 2
- DDSRSEL ;SFISC/MKO-RECORD SELECTION ;7JAN2004
- +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 ;
- PG ;Called from:
- +1 ; DDS01 when user presses SELECT
- +2 ; FIRSTPG^DDS0 if no DA was passed in.
- +3 ;
- +4 ;Returns (if there is a record selection page and we're not in
- +5 ;a multiple)
- +6 ; DDSPG = Record selection page #
- +7 ; DDACT = "NP"
- +8 ; DDSSEL = 1 (undefined if no record selection page)
- +9 ;
- +10 NEW P,P1
- KILL DDSSEL
- +11 ;GFT
- IF $DATA(DDSSC)
- IF $PIECE($GET(DDSSC(DDSSC)),U,4)
- QUIT
- +12 ;
- +13 SET P=""
- SET P1=$PIECE($GET(^DIST(.403,+DDS,21)),U)
- +14 IF P1]""
- Begin DoDot:1
- +15 SET P=$ORDER(^DIST(.403,+DDS,40,"B",P1,""))
- +16 IF P]""
- IF $DATA(^DIST(.403,+DDS,40,P,0))[0
- SET P=""
- End DoDot:1
- +17 ;
- +18 IF P]""
- Begin DoDot:1
- +19 IF $GET(DDO)
- IF $GET(DDSDN)=1
- Begin DoDot:2
- +20 DO ERR3^DDS3
- End DoDot:2
- +21 IF '$TEST
- SET DDSPG=P
- SET DDACT="NP"
- SET DDSSEL=1
- End DoDot:1
- +22 QUIT
- +23 ;
- GDA ;Called from DDS
- +1 ;After a record selection page is closed get the DA from
- +2 ;the first field on the page.
- +3 NEW DDSANS,DDSREC,Y,PG
- +4 SET DDSANS=""
- GFT SET PG=$PIECE($GET(^DIST(.403,+DDS,21)),U)
- if 'PG
- GOTO KILL
- NEW P
- SET P=$ORDER(^(40,"B",PG,0))
- if P
- Begin DoDot:1
- +1 FOR Y=0:0
- SET Y=$ORDER(^DIST(.403,+DDS,40,P,40,Y))
- if 'Y
- QUIT
- IF $GET(^(Y,"COMP MUL"))]""
- KILL Y
- QUIT
- End DoDot:1
- IF '$DATA(Y)
- GOTO KILL
- +2 ;ON THE OLD KIND OF LOOKUP PAGE, THERE IS 1 FIELD, 1 BLOCK
- IF '$TEST
- SET DDSREC=$$GET^DDSVALF(1,1,PG)
- +3 ;
- +4 KILL DA,DDSDAORG
- +5 SET DDSDA=DDSDASV
- SET DDSDL=DDSDLSV
- +6 DO BLDDA^DDS(DDSDA)
- +7 MERGE DDSDAORG=DDSORGSV
- +8 ;
- +9 IF 'DDSREC
- IF DA
- SET DDSREC=DA
- +10 IF '$TEST
- IF DDSREC
- IF DDSREC'=DA
- Begin DoDot:1
- +11 IF DA
- Begin DoDot:2
- +12 SET DDSANS=$$ASKSAVE
- +13 IF DDSANS="R"
- SET DDSREC=DA
- +14 IF '$TEST
- IF DDSANS="S"
- Begin DoDot:3
- +15 DO ^DDS4
- +16 if Y'=1
- SET DDSREC=DA
- End DoDot:3
- End DoDot:2
- if DDSREC=DA
- QUIT
- +17 ;
- +18 SET DA=DDSREC
- +19 DO REC^DDS0(DDP,.DA)
- +20 ;
- +21 IF $GET(DIERR)
- Begin DoDot:2
- +22 DO ERR^DDSMSG
- HANG 2
- +23 SET DA=+$GET(DDSDASV)
- SET DDACT="N"
- +24 DO REC^DDS0(DDP,.DA)
- End DoDot:2
- QUIT
- +25 ;
- +26 SET DDACT="N"
- +27 IF DDSSC=1
- DO FRSTPG^DDS0(DDS,.DA,$GET(DDSPAGE))
- +28 DO CLRDAT
- DO UNLOCK
- End DoDot:1
- +29 ;
- KILL KILL DDSSEL,DDSDASV,DDSDASV,DDSDLSV,DDSORGSV
- +1 QUIT
- +2 ;
- ASKSAVE() ;
- +1 ;Ask user whether to save the previous record
- +2 NEW X,Y
- +3 if DDM
- DO CLRMSG^DDS
- +4 SET DDM=1
- +5 ;
- +6 KILL DIR
- SET DIR(0)="SM^S:SAVE;D:DISCARD;R:RETURN"
- +7 SET DIR("A",1)=" NOTE: You must Save or Discard all edits to the"
- +8 SET DIR("A",2)=" previous record before editing the next record."
- +9 SET DIR("A",3)=" "
- +10 SET DIR("A")="Save, Discard, or Return (S/D/R)"
- +11 SET DIR("B")="SAVE"
- +12 ;
- +13 SET DIR("?",1)="Enter 'S' to save or 'D' to discard."
- +14 SET DIR("?")="Enter 'R' or '^' to return to previous record."
- +15 ;
- +16 SET DIR0=IOSL-1_U_($LENGTH(DIR("A"))+1)_"^7^"_(IOSL-4)_"^0"
- +17 DO ^DIR
- +18 IF $DATA(DIRUT)
- SET Y="R"
- +19 IF '$TEST
- IF X="SAVE"
- SET Y="S"
- +20 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +21 QUIT Y
- +22 ;
- CLRDAT ;Clear all data values from @DDSREFT
- +1 NEW F,P
- +2 SET P=0
- FOR
- SET P=$ORDER(@DDSREFT@(P))
- if 'P
- QUIT
- KILL @DDSREFT@(P)
- +3 SET F="F"
- FOR
- SET F=$ORDER(@DDSREFT@(F))
- if $EXTRACT(F)'="F"
- QUIT
- KILL @DDSREFT@(F)
- +4 QUIT
- +5 ;
- UNLOCK ;Unlock all records locked
- +1 if '$DATA(^TMP("DDS",$JOB,"LOCK"))
- QUIT
- +2 NEW I
- SET I=""
- +3 FOR
- SET I=$ORDER(^TMP("DDS",$JOB,"LOCK",I))
- if I=""
- QUIT
- Begin DoDot:1
- +4 IF I'=(DIE_DA_")")
- LOCK -@I
- KILL ^TMP("DDS",$JOB,"LOCK",I)
- End DoDot:1
- +5 QUIT
