BDGSYS4 ; IHS/ANMC/LJF - ROOM-BED SETUP ;
;;5.3;PIMS;**1007,1009**;FEB 27, 2007
;
;cmi/anch/maw added INITW to show ward on pick list PATCH 1007 item 1007.44
;
EN ; -- main entry point for BDG SYS ROOM SETUP
NEW VALMCNT
D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG SYS ROOM SETUP")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S X=$$GET1^DIQ(40.8,BDGDIV,.01)
S VALMHDR(1)=$$SP(79-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
D INITW Q ;cmi/anch/maw 2/22/2007 added for sort by ward
;cmi/anch/maw 2/22/2007 below is orig code, replaced with INITW PATCH 1007 item 1007.44
D MSG^BDGF("Please wait while I compile the list...",1,0)
NEW IEN,NAME,COUNT,LINE,INA
S VALMCNT=0
K ^TMP("BDGSYS4",$J),^TMP("BDGSYS41",$J)
;
; sort rooms by active/inactive then name
S NAME=0 F S NAME=$O(^DG(405.4,"B",NAME)) Q:NAME="" D
. S IEN=0 F S IEN=$O(^DG(405.4,"B",NAME,IEN)) Q:'IEN D
.. S ^TMP("BDGSYS41",$J,$$GET1^DIQ(405.4,IEN,.2),NAME,IEN)=""
;
; take sorted list and put into display array
; sorted by active/inactive then name
S INA="" F S INA=$O(^TMP("BDGSYS41",$J,INA)) Q:INA="" D
. ;
. I INA=1 D SET("",+$G(COUNT),0,.VALMCNT) ;skip line before inactives
. ;
. S NAME=0 F S NAME=$O(^TMP("BDGSYS41",$J,INA,NAME)) Q:NAME="" D
.. S IEN=0 F S IEN=$O(^TMP("BDGSYS41",$J,INA,NAME,IEN)) Q:'IEN D
... ;
... S COUNT=$G(COUNT)+1
... S LINE=$J(COUNT,2)_". "_NAME ;rooomname
... S LINE=$$PAD(LINE,20)_$$GET1^DIQ(405.4,IEN,.02) ;description
... S LINE=$$PAD(LINE,55)_$$GET1^DIQ(405.4,IEN,9999999.01) ;phone
... ;
... I $$GET1^DIQ(405.4,IEN,.2)=1 S LINE=$$PAD(LINE,68)_"*INACTIVE*"
... D SET(LINE,COUNT,IEN,.VALMCNT)
;
I '$D(^TMP("BDGSYS4",$J)) D
. D SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
Q
;
INITW ; -- init variables and list array
;cmi/anch/maw 2/22/2007 modified code to show ward on list PATCH 1007 item 1007.44
D MSG^BDGF("Please wait while I compile the list...",1,0)
NEW IEN,NAME,COUNT,LINE,INA,OEN
S VALMCNT=0
K ^TMP("BDGSYS4",$J),^TMP("BDGSYS41",$J)
;
; sort rooms by active/inactive then name
S WD=0 F S WD=$O(^DG(405.4,"W",WD)) Q:'WD D
. S NAME=0 F S NAME=$O(^DG(405.4,"W",WD,NAME)) Q:NAME="" D
.. S IEN=0 F S IEN=$O(^DG(405.4,"W",WD,NAME,IEN)) Q:'IEN D
... ;S ^TMP("BDGSYS41",$J,$$GET1^DIQ(405.4,IEN,.2),WD,NAME,IEN)="" ;cmi/maw 8/19/2008 orig line patch 1009
... S ^TMP("BDGSYS41",$J,$$GET1^DIQ(405.4,NAME,.2),WD,NAME,IEN)="" ;cmi/maw 8/19/2008 patch 1009 mod line per mitch wright
;
; take sorted list and put into display array
; sorted by active/inactive then name
S INA="" F S INA=$O(^TMP("BDGSYS41",$J,INA)) Q:INA="" D
. ;
. I INA=1 D SET("",+$G(COUNT),0,.VALMCNT) ;skip line before inactives
. ;
. S NAME=0 F S NAME=$O(^TMP("BDGSYS41",$J,INA,NAME)) Q:NAME="" D
.. S IEN=0 F S IEN=$O(^TMP("BDGSYS41",$J,INA,NAME,IEN)) Q:'IEN D
... S OEN=0 F S OEN=$O(^TMP("BDGSYS41",$J,INA,NAME,IEN,OEN)) Q:'OEN D
.... ;
.... S COUNT=$G(COUNT)+1
.... S LINE=$J(COUNT,2)_". "_$P(^DG(405.4,IEN,0),U)_" ("_$$GET1^DIQ(42,NAME,.01)_")" ;rooomname/ward
.... S LINE=$$PAD(LINE,20)_$$GET1^DIQ(405.4,IEN,.02) ;description cmi/maw 8/19/2008 patch 1009 reported mitch wright
.... ;S LINE=$$PAD(LINE,20)_$$GET1^DIQ(405.4,OEN,.02) ;description orig line
.... S LINE=$$PAD(LINE,55)_$$GET1^DIQ(405.4,IEN,9999999.01) ;phone cmi/maw 8/19/2008 patch 1009 reported mitch wright
.... ;S LINE=$$PAD(LINE,55)_$$GET1^DIQ(405.4,OEN,9999999.01) ;phone orig line
.... ;
.... I $$GET1^DIQ(405.4,IEN,.2)=1 S LINE=$$PAD(LINE,68)_"*INACTIVE*"
.... D SET(LINE,COUNT,IEN,.VALMCNT)
;
I '$D(^TMP("BDGSYS4",$J)) D
. D SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
Q
;
SET(DATA,NUM,N,LINE) ; put display line into array
S LINE=LINE+1
S ^TMP("BDGSYS4",$J,LINE,0)=DATA
S ^TMP("BDGSYS4",$J,"IDX",LINE,NUM)=N
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGSYS4",$J)
Q
;
EXPND ; -- expand code
Q
;
RESET ; -- update partition for return to list manager
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
D HDR,INIT
Q
;
ADD ;EP; called by Add Entry protocol
NEW DIC,DLAYGO,Y,DDSFILE,DA,DR,DGNEW
D FULL^VALM1
S (DIC,DLAYGO)=405.4,DIC(0)="AEMQZL" D ^DIC K DIC I Y<1 D RESET Q
S DDSFILE=405.4,DA=+Y,DR="[BDG 405.4 SETUP]",DGNEW=1 D ^DDS
D RESET
Q
;
EDIT ;EP; called by Edit Entry protocol
NEW X,Y,Z,BDGN,DDSFILE,DA,DR,DGNEW
D FULL^VALM1
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
S X=0 F S X=$O(VALMY(X)) Q:X="" D
. ;7/18/02 WAR - REMd next line and changed code per LJF15
. ;S Y=0 F S Y=$O(^TMP("BDGSYS4",$J,"IDX",Y)) Q:Y="" D
. S Y=0 F S Y=$O(^TMP("BDGSYS4",$J,"IDX",Y)) Q:Y="" Q:$G(BDGN) D
.. S Z=$O(^TMP("BDGSYS4",$J,"IDX",Y,0))
.. Q:^TMP("BDGSYS4",$J,"IDX",Y,Z)=""
.. I Z=X S BDGN=^TMP("BDGSYS4",$J,"IDX",Y,Z)
;
I 'BDGN D RESET Q
S DDSFILE=405.4,DA=BDGN,DR="[BDG 405.4 SETUP]",DGNEW=1 D ^DDS
D RESET
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BDGSYS4 ; IHS/ANMC/LJF - ROOM-BED SETUP ;
+1 ;;5.3;PIMS;**1007,1009**;FEB 27, 2007
+2 ;
+3 ;cmi/anch/maw added INITW to show ward on pick list PATCH 1007 item 1007.44
+4 ;
EN ; -- main entry point for BDG SYS ROOM SETUP
+1 NEW VALMCNT
+2 DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG SYS ROOM SETUP")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET X=$$GET1^DIQ(40.8,BDGDIV,.01)
+3 SET VALMHDR(1)=$$SP(79-$LENGTH(X)\2)_X
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 ;cmi/anch/maw 2/22/2007 added for sort by ward
DO INITW
QUIT
+2 ;cmi/anch/maw 2/22/2007 below is orig code, replaced with INITW PATCH 1007 item 1007.44
+3 DO MSG^BDGF("Please wait while I compile the list...",1,0)
+4 NEW IEN,NAME,COUNT,LINE,INA
+5 SET VALMCNT=0
+6 KILL ^TMP("BDGSYS4",$JOB),^TMP("BDGSYS41",$JOB)
+7 ;
+8 ; sort rooms by active/inactive then name
+9 SET NAME=0
FOR
SET NAME=$ORDER(^DG(405.4,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+10 SET IEN=0
FOR
SET IEN=$ORDER(^DG(405.4,"B",NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+11 SET ^TMP("BDGSYS41",$JOB,$$GET1^DIQ(405.4,IEN,.2),NAME,IEN)=""
End DoDot:2
End DoDot:1
+12 ;
+13 ; take sorted list and put into display array
+14 ; sorted by active/inactive then name
+15 SET INA=""
FOR
SET INA=$ORDER(^TMP("BDGSYS41",$JOB,INA))
IF INA=""
QUIT
Begin DoDot:1
+16 ;
+17 ;skip line before inactives
IF INA=1
DO SET("",+$GET(COUNT),0,.VALMCNT)
+18 ;
+19 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGSYS41",$JOB,INA,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+20 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGSYS41",$JOB,INA,NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+21 ;
+22 SET COUNT=$GET(COUNT)+1
+23 ;rooomname
SET LINE=$JUSTIFY(COUNT,2)_". "_NAME
+24 ;description
SET LINE=$$PAD(LINE,20)_$$GET1^DIQ(405.4,IEN,.02)
+25 ;phone
SET LINE=$$PAD(LINE,55)_$$GET1^DIQ(405.4,IEN,9999999.01)
+26 ;
+27 IF $$GET1^DIQ(405.4,IEN,.2)=1
SET LINE=$$PAD(LINE,68)_"*INACTIVE*"
+28 DO SET(LINE,COUNT,IEN,.VALMCNT)
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 IF '$DATA(^TMP("BDGSYS4",$JOB))
Begin DoDot:1
+31 DO SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
End DoDot:1
+32 QUIT
+33 ;
INITW ; -- init variables and list array
+1 ;cmi/anch/maw 2/22/2007 modified code to show ward on list PATCH 1007 item 1007.44
+2 DO MSG^BDGF("Please wait while I compile the list...",1,0)
+3 NEW IEN,NAME,COUNT,LINE,INA,OEN
+4 SET VALMCNT=0
+5 KILL ^TMP("BDGSYS4",$JOB),^TMP("BDGSYS41",$JOB)
+6 ;
+7 ; sort rooms by active/inactive then name
+8 SET WD=0
FOR
SET WD=$ORDER(^DG(405.4,"W",WD))
IF 'WD
QUIT
Begin DoDot:1
+9 SET NAME=0
FOR
SET NAME=$ORDER(^DG(405.4,"W",WD,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+10 SET IEN=0
FOR
SET IEN=$ORDER(^DG(405.4,"W",WD,NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+11 ;S ^TMP("BDGSYS41",$J,$$GET1^DIQ(405.4,IEN,.2),WD,NAME,IEN)="" ;cmi/maw 8/19/2008 orig line patch 1009
+12 ;cmi/maw 8/19/2008 patch 1009 mod line per mitch wright
SET ^TMP("BDGSYS41",$JOB,$$GET1^DIQ(405.4,NAME,.2),WD,NAME,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
+14 ; take sorted list and put into display array
+15 ; sorted by active/inactive then name
+16 SET INA=""
FOR
SET INA=$ORDER(^TMP("BDGSYS41",$JOB,INA))
IF INA=""
QUIT
Begin DoDot:1
+17 ;
+18 ;skip line before inactives
IF INA=1
DO SET("",+$GET(COUNT),0,.VALMCNT)
+19 ;
+20 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGSYS41",$JOB,INA,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+21 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGSYS41",$JOB,INA,NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+22 SET OEN=0
FOR
SET OEN=$ORDER(^TMP("BDGSYS41",$JOB,INA,NAME,IEN,OEN))
IF 'OEN
QUIT
Begin DoDot:4
+23 ;
+24 SET COUNT=$GET(COUNT)+1
+25 ;rooomname/ward
SET LINE=$JUSTIFY(COUNT,2)_". "_$PIECE(^DG(405.4,IEN,0),U)_" ("_$$GET1^DIQ(42,NAME,.01)_")"
+26 ;description cmi/maw 8/19/2008 patch 1009 reported mitch wright
SET LINE=$$PAD(LINE,20)_$$GET1^DIQ(405.4,IEN,.02)
+27 ;S LINE=$$PAD(LINE,20)_$$GET1^DIQ(405.4,OEN,.02) ;description orig line
+28 ;phone cmi/maw 8/19/2008 patch 1009 reported mitch wright
SET LINE=$$PAD(LINE,55)_$$GET1^DIQ(405.4,IEN,9999999.01)
+29 ;S LINE=$$PAD(LINE,55)_$$GET1^DIQ(405.4,OEN,9999999.01) ;phone orig line
+30 ;
+31 IF $$GET1^DIQ(405.4,IEN,.2)=1
SET LINE=$$PAD(LINE,68)_"*INACTIVE*"
+32 DO SET(LINE,COUNT,IEN,.VALMCNT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 IF '$DATA(^TMP("BDGSYS4",$JOB))
Begin DoDot:1
+35 DO SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
End DoDot:1
+36 QUIT
+37 ;
SET(DATA,NUM,N,LINE) ; put display line into array
+1 SET LINE=LINE+1
+2 SET ^TMP("BDGSYS4",$JOB,LINE,0)=DATA
+3 SET ^TMP("BDGSYS4",$JOB,"IDX",LINE,NUM)=N
+4 QUIT
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGSYS4",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
RESET ; -- update partition for return to list manager
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 DO HDR
DO INIT
+4 QUIT
+5 ;
ADD ;EP; called by Add Entry protocol
+1 NEW DIC,DLAYGO,Y,DDSFILE,DA,DR,DGNEW
+2 DO FULL^VALM1
+3 SET (DIC,DLAYGO)=405.4
SET DIC(0)="AEMQZL"
DO ^DIC
KILL DIC
IF Y<1
DO RESET
QUIT
+4 SET DDSFILE=405.4
SET DA=+Y
SET DR="[BDG 405.4 SETUP]"
SET DGNEW=1
DO ^DDS
+5 DO RESET
+6 QUIT
+7 ;
EDIT ;EP; called by Edit Entry protocol
+1 NEW X,Y,Z,BDGN,DDSFILE,DA,DR,DGNEW
+2 DO FULL^VALM1
+3 DO EN^VALM2(XQORNOD(0),"OS")
+4 IF '$DATA(VALMY)
QUIT
+5 SET X=0
FOR
SET X=$ORDER(VALMY(X))
IF X=""
QUIT
Begin DoDot:1
+6 ;7/18/02 WAR - REMd next line and changed code per LJF15
+7 ;S Y=0 F S Y=$O(^TMP("BDGSYS4",$J,"IDX",Y)) Q:Y="" D
+8 SET Y=0
FOR
SET Y=$ORDER(^TMP("BDGSYS4",$JOB,"IDX",Y))
IF Y=""
QUIT
IF $GET(BDGN)
QUIT
Begin DoDot:2
+9 SET Z=$ORDER(^TMP("BDGSYS4",$JOB,"IDX",Y,0))
+10 IF ^TMP("BDGSYS4",$JOB,"IDX",Y,Z)=""
QUIT
+11 IF Z=X
SET BDGN=^TMP("BDGSYS4",$JOB,"IDX",Y,Z)
End DoDot:2
End DoDot:1
+12 ;
+13 IF 'BDGN
DO RESET
QUIT
+14 SET DDSFILE=405.4
SET DA=BDGN
SET DR="[BDG 405.4 SETUP]"
SET DGNEW=1
DO ^DDS
+15 DO RESET
+16 QUIT
+17 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
