BDGSYS3 ; IHS/ANMC/LJF - INPATIENT WARD SETUP ; [ 04/09/2004 8:18 AM ]
;;5.3;PIMS;**1005**;MAY 28, 2004
;IHS/OIT/LJF 04/27/2006 PATCH 1005 changed ScreenMan form to use authorization dates
;
EN ; -- main entry point for BDG SYS WARD SETUP
NEW VALMCNT
D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG SYS WARD 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 MSG^BDGF("Pleaes wait while I compile the list...",1,0)
NEW IEN,DIV,INA,NAME
S VALMCNT=0
K ^TMP("BDGSYS3",$J),^TMP("BDGSYS31",$J)
;
; loop thru wards and sort by division, active/inactive, then name
S NAME=0 F S NAME=$O(^DIC(42,"B",NAME)) Q:NAME="" D
. S IEN=0 F S IEN=$O(^DIC(42,"B",NAME,IEN)) Q:'IEN D
.. Q:'$D(^BDGWD(IEN)) ;not in IHS Ward file (old deleted ward?)
.. S DIV=$$GET1^DIQ(42,IEN,.015) I DIV="" S DIV="??"
.. S INA=$S($$GET1^DIQ(9009016.5,IEN,.03,"I")="I":"INACTIVE",1:"ACTIVE")
.. S ^TMP("BDGSYS31",$J,DIV,INA,NAME,IEN)=""
;
; take sorted list and create display lines
NEW A,B,C,D,COUNT
S A=0 F S A=$O(^TMP("BDGSYS31",$J,A)) Q:A="" D
. S B=0 F S B=$O(^TMP("BDGSYS31",$J,A,B)) Q:B="" D
.. S C=0 F S C=$O(^TMP("BDGSYS31",$J,A,B,C)) Q:C="" D
... S D=0 F S D=$O(^TMP("BDGSYS31",$J,A,B,C,D)) Q:'D D
.... D LINE(A,B,C,D,.COUNT)
;
I '$D(^TMP("BDGSYS3",$J)) D
. D SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
K ^TMP("BDGSYS31",$J)
Q
;
LINE(DIV,INA,NAME,IEN,COUNT) ; create display line
NEW LINE
S COUNT=$G(COUNT)+1
S LINE=$J(COUNT,2)_". "_NAME ;ward name
S LINE=$$PAD(LINE,32)_$$GET1^DIQ(9009016.5,IEN,.02) ;abbrev
S LINE=$$PAD(LINE,42)_$E(DIV,1,15) ;division
;
I $$GET1^DIQ(9009016.5,IEN,.03)="INACTIVE" D Q ;inactive
. S LINE=$$PAD(LINE,60)_"** INACTIVE **"
. D SET(LINE,COUNT,IEN,.VALMCNT)
;
S LINE=$$PAD(LINE,60)
I $$GET1^DIQ(9009016.5,IEN,101)="YES" S LINE=LINE_" ICU"
I $$GET1^DIQ(9009016.5,IEN,105)="YES" S LINE=LINE_" PCU"
I $$GET1^DIQ(42,IEN,.09,"I")=1 S LINE=LINE_" SI WARD"
D SET(LINE,COUNT,IEN,.VALMCNT)
Q
;
SET(DATA,NUM,N,LINE) ; put display line into array
S LINE=LINE+1
S ^TMP("BDGSYS3",$J,LINE,0)=DATA
S ^TMP("BDGSYS3",$J,"IDX",LINE,NUM)=N
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGSYS3",$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 INIT,HDR
Q
;
ADD ;EP; called by Add Entry protocol
NEW DIC,DLAYGO,Y,DDSFILE,DA,DR
D FULL^VALM1
;
NEW GNL F GNL=1:1 Q:'$D(^DIC(42,"AGL",GNL))
S (DIC,DLAYGO)=42,DIC(0)="AEMQZL",DIC("DR")="44;.015;400///"_GNL
;
D ^DIC K DIC I Y<1 D RESET Q
S (DIC,DLAYGO)=9009016.5,DIC(0)="L",X=$P(Y,U,2),DINUM=+Y
D ^DIC I Y<1 D RESET Q
;S DDSFILE=9009016.5,DA=+Y,DR="[BDG 9009016.5 SETUP]" D ^DDS
S DDSFILE=9009016.5,DA=+Y,DR="[BDG 9009016.5 SETUP 2]" D ^DDS ;IHS/OIT/LJF 04/27/2006 PATCH 1005
D RESET
Q
;
EDIT ;EP; called by Edit Entry protocol
NEW X,Y,Z,BDGN,DDSFILE,DA,DR
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
. S Y=0 F S Y=$O(^TMP("BDGSYS3",$J,"IDX",Y)) Q:Y="" D
.. S Z=$O(^TMP("BDGSYS3",$J,"IDX",Y,0))
.. Q:^TMP("BDGSYS3",$J,"IDX",Y,Z)=""
.. I Z=X S BDGN=^TMP("BDGSYS3",$J,"IDX",Y,Z)
;
I 'BDGN D RESET Q
;S DDSFILE=9009016.5,DA=BDGN,DR="[BDG 9009016.5 SETUP]" D ^DDS
S DDSFILE=9009016.5,DA=BDGN,DR="[BDG 9009016.5 SETUP 2]" D ^DDS ;IHS/OIT/LJF 04/27/2006 PATCH 1005
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)
BDGSYS3 ; IHS/ANMC/LJF - INPATIENT WARD SETUP ; [ 04/09/2004 8:18 AM ]
+1 ;;5.3;PIMS;**1005**;MAY 28, 2004
+2 ;IHS/OIT/LJF 04/27/2006 PATCH 1005 changed ScreenMan form to use authorization dates
+3 ;
EN ; -- main entry point for BDG SYS WARD SETUP
+1 NEW VALMCNT
+2 DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG SYS WARD 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 DO MSG^BDGF("Pleaes wait while I compile the list...",1,0)
+2 NEW IEN,DIV,INA,NAME
+3 SET VALMCNT=0
+4 KILL ^TMP("BDGSYS3",$JOB),^TMP("BDGSYS31",$JOB)
+5 ;
+6 ; loop thru wards and sort by division, active/inactive, then name
+7 SET NAME=0
FOR
SET NAME=$ORDER(^DIC(42,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+8 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(42,"B",NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+9 ;not in IHS Ward file (old deleted ward?)
IF '$DATA(^BDGWD(IEN))
QUIT
+10 SET DIV=$$GET1^DIQ(42,IEN,.015)
IF DIV=""
SET DIV="??"
+11 SET INA=$SELECT($$GET1^DIQ(9009016.5,IEN,.03,"I")="I":"INACTIVE",1:"ACTIVE")
+12 SET ^TMP("BDGSYS31",$JOB,DIV,INA,NAME,IEN)=""
End DoDot:2
End DoDot:1
+13 ;
+14 ; take sorted list and create display lines
+15 NEW A,B,C,D,COUNT
+16 SET A=0
FOR
SET A=$ORDER(^TMP("BDGSYS31",$JOB,A))
IF A=""
QUIT
Begin DoDot:1
+17 SET B=0
FOR
SET B=$ORDER(^TMP("BDGSYS31",$JOB,A,B))
IF B=""
QUIT
Begin DoDot:2
+18 SET C=0
FOR
SET C=$ORDER(^TMP("BDGSYS31",$JOB,A,B,C))
IF C=""
QUIT
Begin DoDot:3
+19 SET D=0
FOR
SET D=$ORDER(^TMP("BDGSYS31",$JOB,A,B,C,D))
IF 'D
QUIT
Begin DoDot:4
+20 DO LINE(A,B,C,D,.COUNT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 IF '$DATA(^TMP("BDGSYS3",$JOB))
Begin DoDot:1
+23 DO SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
End DoDot:1
+24 KILL ^TMP("BDGSYS31",$JOB)
+25 QUIT
+26 ;
LINE(DIV,INA,NAME,IEN,COUNT) ; create display line
+1 NEW LINE
+2 SET COUNT=$GET(COUNT)+1
+3 ;ward name
SET LINE=$JUSTIFY(COUNT,2)_". "_NAME
+4 ;abbrev
SET LINE=$$PAD(LINE,32)_$$GET1^DIQ(9009016.5,IEN,.02)
+5 ;division
SET LINE=$$PAD(LINE,42)_$EXTRACT(DIV,1,15)
+6 ;
+7 ;inactive
IF $$GET1^DIQ(9009016.5,IEN,.03)="INACTIVE"
Begin DoDot:1
+8 SET LINE=$$PAD(LINE,60)_"** INACTIVE **"
+9 DO SET(LINE,COUNT,IEN,.VALMCNT)
End DoDot:1
QUIT
+10 ;
+11 SET LINE=$$PAD(LINE,60)
+12 IF $$GET1^DIQ(9009016.5,IEN,101)="YES"
SET LINE=LINE_" ICU"
+13 IF $$GET1^DIQ(9009016.5,IEN,105)="YES"
SET LINE=LINE_" PCU"
+14 IF $$GET1^DIQ(42,IEN,.09,"I")=1
SET LINE=LINE_" SI WARD"
+15 DO SET(LINE,COUNT,IEN,.VALMCNT)
+16 QUIT
+17 ;
SET(DATA,NUM,N,LINE) ; put display line into array
+1 SET LINE=LINE+1
+2 SET ^TMP("BDGSYS3",$JOB,LINE,0)=DATA
+3 SET ^TMP("BDGSYS3",$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("BDGSYS3",$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 INIT
DO HDR
+4 QUIT
+5 ;
ADD ;EP; called by Add Entry protocol
+1 NEW DIC,DLAYGO,Y,DDSFILE,DA,DR
+2 DO FULL^VALM1
+3 ;
+4 NEW GNL
FOR GNL=1:1
IF '$DATA(^DIC(42,"AGL",GNL))
QUIT
+5 SET (DIC,DLAYGO)=42
SET DIC(0)="AEMQZL"
SET DIC("DR")="44;.015;400///"_GNL
+6 ;
+7 DO ^DIC
KILL DIC
IF Y<1
DO RESET
QUIT
+8 SET (DIC,DLAYGO)=9009016.5
SET DIC(0)="L"
SET X=$PIECE(Y,U,2)
SET DINUM=+Y
+9 DO ^DIC
IF Y<1
DO RESET
QUIT
+10 ;S DDSFILE=9009016.5,DA=+Y,DR="[BDG 9009016.5 SETUP]" D ^DDS
+11 ;IHS/OIT/LJF 04/27/2006 PATCH 1005
SET DDSFILE=9009016.5
SET DA=+Y
SET DR="[BDG 9009016.5 SETUP 2]"
DO ^DDS
+12 DO RESET
+13 QUIT
+14 ;
EDIT ;EP; called by Edit Entry protocol
+1 NEW X,Y,Z,BDGN,DDSFILE,DA,DR
+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 SET Y=0
FOR
SET Y=$ORDER(^TMP("BDGSYS3",$JOB,"IDX",Y))
IF Y=""
QUIT
Begin DoDot:2
+7 SET Z=$ORDER(^TMP("BDGSYS3",$JOB,"IDX",Y,0))
+8 IF ^TMP("BDGSYS3",$JOB,"IDX",Y,Z)=""
QUIT
+9 IF Z=X
SET BDGN=^TMP("BDGSYS3",$JOB,"IDX",Y,Z)
End DoDot:2
End DoDot:1
+10 ;
+11 IF 'BDGN
DO RESET
QUIT
+12 ;S DDSFILE=9009016.5,DA=BDGN,DR="[BDG 9009016.5 SETUP]" D ^DDS
+13 ;IHS/OIT/LJF 04/27/2006 PATCH 1005
SET DDSFILE=9009016.5
SET DA=BDGN
SET DR="[BDG 9009016.5 SETUP 2]"
DO ^DDS
+14 DO RESET
+15 QUIT
+16 ;
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)
