DGRURB ; ALB/SCK - LIST MANAGER INTERFACE FOR ROOM-BED TRANSLATION; 16-FEB-2000
;;5.3;Registration;**190,312**;Aug 13, 1993
;
EN ; -- main entry point for DGRU ROOM-BED
K XQORS,VALMEVL
N VALMCNT,DGRUCNT,VALMI,VALMY,XQORNOD,VALMBCK,VALMHDR
D EN^VALM("DGRU ROOM-BED")
Q
;
HDR ; -- header code
S VALMHDR(1)="RAI/MDS COTS Room-Bed Translation"
S VALMHDR(2)="Data Entry Screen"
Q
;
INIT ; -- init variables and list array
; Variables
; DGIEN - ien of the file #46.13 entry
; DGNODE - Zero node of file #46.13
; DGCNT - Count of entries in the LM array
; DGTRN - File #46.13 ien^translated Room-Bed^Bed description
; DGRM - Room-Bed name in external format
;
N DGIEN,DGNODE,DGTRN,DGCNT,X,DGRM
;
K ^TMP("DGRURB",$J)
K ^TMP("DGRUSRT",$J)
;
D CLEAN^VALM10
;; Sort Room-Beds first
S (DGIEN,VALMCNT)=0
F S DGIEN=$O(^DGRU(46.13,DGIEN)) Q:'DGIEN D
. S DGNODE=$G(^DGRU(46.13,DGIEN,0))
. Q:DGNODE']""
. S ^TMP("DGRUSRT",$J,$E($$GET1^DIQ(405.4,+DGNODE,.01),1,20),+DGNODE)=DGIEN_"^"_$P(DGNODE,"^",2)_"^"_$E($$GET1^DIQ(405.4,+DGNODE,.02),1,30)
;
;; Build display list
S DGRM="",DGCNT=1
F S DGRM=$O(^TMP("DGRUSRT",$J,DGRM)) Q:DGRM="" D
. S DGIEN=0
. F S DGIEN=$O(^TMP("DGRUSRT",$J,DGRM,DGIEN)) Q:'DGIEN D
. . S DGTRN=^TMP("DGRUSRT",$J,DGRM,DGIEN)
. . S X=$$SETFLD^VALM1(DGCNT,"","NUM")
. . S X=$$SETFLD^VALM1(DGRM,X,"VISTA")
. . S X=$$SETFLD^VALM1($P(DGTRN,"^",2),X,"COTS")
. . S X=$$SETFLD^VALM1($P(DGTRN,"^",3),X,"RMDESC")
. . D SET(X,DGCNT,+DGTRN)
. . S DGCNT=DGCNT+1
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("DGRURB",$J)
K ^TMP("DGRUSRT",$J)
D FULL^VALM1
D CLEAN^VALM10
Q
;
ADD ; Add a new room-bed translation value
N DIR,DIRUT,DGVM,DGTR,FDA
;
D FULL^VALM1
S DIR(0)="PAO^405.4:EMZ",DIR("A")="Vista Room-Bed: "
S DIR("S")="I $$RAI^DGRURB(Y)"
D ^DIR K DIR
Q:$D(DIRUT)
S DGVM=+Y
;
K DIRUT
S DIR(0)="FA^3:8^K:'X?.5UN1""-"".2UN"
S DIR("A")="Enter Translated Room-Bed: "
S DIR("?",1)="Answer must be 3-8 characters in length"
S DIR("?",2)="in the format xxxxx-xx, where the first piece does"
S DIR("?")="not exceed 5 characters, and the second does not exceed 2."
D ^DIR K DIR
Q:$D(DIRUT)
S DGTR=$G(Y)
;
S FDA(1,46.13,"?+1,",.01)=DGVM
S FDA(1,46.13,"?+1,",.02)=DGTR
D UPDATE^DIE("","FDA(1)")
;
D INIT
Q
;
DEL ; Delete an existing room-bed translation value
N DA,DIK
;
D FULL^VALM1
D EN^VALM2(XQORNOD(0),"OS")
S VALMI=0
S VALMI=$O(VALMY(VALMI))
Q:'VALMI
;
S DIR(0)="YAO",DIR("A")="Are you sure you want to delete this translation? "
S DIR("B")="NO"
D ^DIR K DIR
Q:$D(DIRUT)
I Y D
. S DA=^TMP("DGRURB",$J,"IDX",VALMI,VALMI)
. S DIK="^DGRU(46.13,"
. D ^DIK
. D INIT
Q
;
RAI(DGIEN) ; Screening logic for room lookup. Associated ward must have the
; RAI/MDS WARD field = "Yes"
N DGOK,DGNDX
;
S DGNDX=0,DGOK=0
F S DGNDX=$O(^DG(405.4,DGIEN,"W",DGNDX)) Q:'DGNDX D G:DGOK=1 EXITSC
. S DGOK=$$GET1^DIQ(42,DGNDX,.035,"I")
EXITSC Q DGOK
;
SET(X,DGCNT,DGIEN) ;
S VALMCNT=$G(VALMCNT)+1
S ^TMP("DGRURB",$J,VALMCNT,0)=X
S ^TMP("DGRURB",$J,"IDX",VALMCNT,DGCNT)=DGIEN
S ^TMP("DGRURB",$J,"INIT",VALMCNT,DGCNT)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRURB 3282 printed Oct 16, 2024@18:59:13 Page 2
DGRURB ; ALB/SCK - LIST MANAGER INTERFACE FOR ROOM-BED TRANSLATION; 16-FEB-2000
+1 ;;5.3;Registration;**190,312**;Aug 13, 1993
+2 ;
EN ; -- main entry point for DGRU ROOM-BED
+1 KILL XQORS,VALMEVL
+2 NEW VALMCNT,DGRUCNT,VALMI,VALMY,XQORNOD,VALMBCK,VALMHDR
+3 DO EN^VALM("DGRU ROOM-BED")
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)="RAI/MDS COTS Room-Bed Translation"
+2 SET VALMHDR(2)="Data Entry Screen"
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 ; Variables
+2 ; DGIEN - ien of the file #46.13 entry
+3 ; DGNODE - Zero node of file #46.13
+4 ; DGCNT - Count of entries in the LM array
+5 ; DGTRN - File #46.13 ien^translated Room-Bed^Bed description
+6 ; DGRM - Room-Bed name in external format
+7 ;
+8 NEW DGIEN,DGNODE,DGTRN,DGCNT,X,DGRM
+9 ;
+10 KILL ^TMP("DGRURB",$JOB)
+11 KILL ^TMP("DGRUSRT",$JOB)
+12 ;
+13 DO CLEAN^VALM10
+14 ;; Sort Room-Beds first
+15 SET (DGIEN,VALMCNT)=0
+16 FOR
SET DGIEN=$ORDER(^DGRU(46.13,DGIEN))
if 'DGIEN
QUIT
Begin DoDot:1
+17 SET DGNODE=$GET(^DGRU(46.13,DGIEN,0))
+18 if DGNODE']""
QUIT
+19 SET ^TMP("DGRUSRT",$JOB,$EXTRACT($$GET1^DIQ(405.4,+DGNODE,.01),1,20),+DGNODE)=DGIEN_"^"_$PIECE(DGNODE,"^",2)_"^"_$EXTRACT($$GET1^DIQ(405.4,+DGNODE,.02),1,30)
End DoDot:1
+20 ;
+21 ;; Build display list
+22 SET DGRM=""
SET DGCNT=1
+23 FOR
SET DGRM=$ORDER(^TMP("DGRUSRT",$JOB,DGRM))
if DGRM=""
QUIT
Begin DoDot:1
+24 SET DGIEN=0
+25 FOR
SET DGIEN=$ORDER(^TMP("DGRUSRT",$JOB,DGRM,DGIEN))
if 'DGIEN
QUIT
Begin DoDot:2
+26 SET DGTRN=^TMP("DGRUSRT",$JOB,DGRM,DGIEN)
+27 SET X=$$SETFLD^VALM1(DGCNT,"","NUM")
+28 SET X=$$SETFLD^VALM1(DGRM,X,"VISTA")
+29 SET X=$$SETFLD^VALM1($PIECE(DGTRN,"^",2),X,"COTS")
+30 SET X=$$SETFLD^VALM1($PIECE(DGTRN,"^",3),X,"RMDESC")
+31 DO SET(X,DGCNT,+DGTRN)
+32 SET DGCNT=DGCNT+1
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("DGRURB",$JOB)
+2 KILL ^TMP("DGRUSRT",$JOB)
+3 DO FULL^VALM1
+4 DO CLEAN^VALM10
+5 QUIT
+6 ;
ADD ; Add a new room-bed translation value
+1 NEW DIR,DIRUT,DGVM,DGTR,FDA
+2 ;
+3 DO FULL^VALM1
+4 SET DIR(0)="PAO^405.4:EMZ"
SET DIR("A")="Vista Room-Bed: "
+5 SET DIR("S")="I $$RAI^DGRURB(Y)"
+6 DO ^DIR
KILL DIR
+7 if $DATA(DIRUT)
QUIT
+8 SET DGVM=+Y
+9 ;
+10 KILL DIRUT
+11 SET DIR(0)="FA^3:8^K:'X?.5UN1""-"".2UN"
+12 SET DIR("A")="Enter Translated Room-Bed: "
+13 SET DIR("?",1)="Answer must be 3-8 characters in length"
+14 SET DIR("?",2)="in the format xxxxx-xx, where the first piece does"
+15 SET DIR("?")="not exceed 5 characters, and the second does not exceed 2."
+16 DO ^DIR
KILL DIR
+17 if $DATA(DIRUT)
QUIT
+18 SET DGTR=$GET(Y)
+19 ;
+20 SET FDA(1,46.13,"?+1,",.01)=DGVM
+21 SET FDA(1,46.13,"?+1,",.02)=DGTR
+22 DO UPDATE^DIE("","FDA(1)")
+23 ;
+24 DO INIT
+25 QUIT
+26 ;
DEL ; Delete an existing room-bed translation value
+1 NEW DA,DIK
+2 ;
+3 DO FULL^VALM1
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 SET VALMI=0
+6 SET VALMI=$ORDER(VALMY(VALMI))
+7 if 'VALMI
QUIT
+8 ;
+9 SET DIR(0)="YAO"
SET DIR("A")="Are you sure you want to delete this translation? "
+10 SET DIR("B")="NO"
+11 DO ^DIR
KILL DIR
+12 if $DATA(DIRUT)
QUIT
+13 IF Y
Begin DoDot:1
+14 SET DA=^TMP("DGRURB",$JOB,"IDX",VALMI,VALMI)
+15 SET DIK="^DGRU(46.13,"
+16 DO ^DIK
+17 DO INIT
End DoDot:1
+18 QUIT
+19 ;
RAI(DGIEN) ; Screening logic for room lookup. Associated ward must have the
+1 ; RAI/MDS WARD field = "Yes"
+2 NEW DGOK,DGNDX
+3 ;
+4 SET DGNDX=0
SET DGOK=0
+5 FOR
SET DGNDX=$ORDER(^DG(405.4,DGIEN,"W",DGNDX))
if 'DGNDX
QUIT
Begin DoDot:1
+6 SET DGOK=$$GET1^DIQ(42,DGNDX,.035,"I")
End DoDot:1
if DGOK=1
GOTO EXITSC
EXITSC QUIT DGOK
+1 ;
SET(X,DGCNT,DGIEN) ;
+1 SET VALMCNT=$GET(VALMCNT)+1
+2 SET ^TMP("DGRURB",$JOB,VALMCNT,0)=X
+3 SET ^TMP("DGRURB",$JOB,"IDX",VALMCNT,DGCNT)=DGIEN
+4 SET ^TMP("DGRURB",$JOB,"INIT",VALMCNT,DGCNT)=""
+5 QUIT
