BDGSYS2 ; IHS/ANMC/LJF - TREATING SPECIALTY SETUP ;
;;5.3;PIMS;;APR 26, 2002
;
EN ; -- main entry point for BDG SYS TREAT SPEC SETUP
NEW VALMCNT
D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG SYS TREAT SPEC 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("Please wait while I compile the list...",1,0)
NEW CODE,IEN,COUNT,LINE,Y
S VALMCNT=0
K ^TMP("BDGSYS2",$J)
S NAME=0
F S NAME=$O(^DIC(45.7,"B",NAME)) Q:NAME="" D
. S IEN=0
. F S IEN=$O(^DIC(45.7,"B",NAME,IEN)) Q:'IEN D
.. S CODE=$$GET1^DIQ(45.7,IEN,9999999.01) Q:CODE="00" ;bad entry
.. ;
.. S COUNT=$G(COUNT)+1
.. S LINE=$J(COUNT,2)_". "_NAME ;service name
.. S LINE=$$PAD(LINE,32)_$$GET1^DIQ(45.7,IEN,99) ;abbreviation
.. S LINE=$$PAD(LINE,39)_CODE
.. S LINE=$$PAD(LINE,45)_$$SRV(IEN) ;hos service
.. S LINE=$$PAD(LINE,61)_$$LASTDATE(IEN) ;active date
.. D SET(LINE,COUNT,IEN,.VALMCNT)
;
I '$D(^TMP("BDGSYS2",$J)) D
. D SET("*** NO ENTRIES FOUND WITH IHS CODES!! ***",0,0,.VALMCNT)
Q
;
LASTDATE(N) ; find latest effective date and active status
NEW X,Y
I $$GET1^DIQ(45.7,N,9999999.03)'="YES" Q "" ;admitting service?
S X=$O(^DIC(45.7,N,"E","ADATE","")) I X="" Q "No effective date"
S Y=$O(^DIC(45.7,N,"E","ADATE",X,0)) I 'Y Q "Bad entry"
I $$GET1^DIQ(45.702,Y_","_N,.02)'="YES" Q "Inactive" ;active?
Q "YES - "_$$PAD($$FMTE^XLFDT(-X),14)
;
SRV(N) ; returns hospital service for entry
Q $E($P($$GET1^DIQ(45.7,IEN,2)," SERVICE"),1,15)
;
SET(DATA,NUM,N,LINE) ; put display line into array
S LINE=LINE+1
S ^TMP("BDGSYS2",$J,LINE,0)=DATA
S ^TMP("BDGSYS2",$J,"IDX",LINE,NUM)=N
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGSYS2",$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
;
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("BDGSYS2",$J,"IDX",Y)) Q:Y="" D
.. S Z=$O(^TMP("BDGSYS2",$J,"IDX",Y,0))
.. Q:^TMP("BDGSYS2",$J,"IDX",Y,Z)=""
.. I Z=X S BDGN=^TMP("BDGSYS2",$J,"IDX",Y,Z)
;
I 'BDGN D RESET Q
S DDSFILE=45.7,DA=BDGN,DR="[BDG 45.7 SETUP]" 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)
BDGSYS2 ; IHS/ANMC/LJF - TREATING SPECIALTY SETUP ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
EN ; -- main entry point for BDG SYS TREAT SPEC SETUP
+1 NEW VALMCNT
+2 DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG SYS TREAT SPEC 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("Please wait while I compile the list...",1,0)
+2 NEW CODE,IEN,COUNT,LINE,Y
+3 SET VALMCNT=0
+4 KILL ^TMP("BDGSYS2",$JOB)
+5 SET NAME=0
+6 FOR
SET NAME=$ORDER(^DIC(45.7,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^DIC(45.7,"B",NAME,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+9 ;bad entry
SET CODE=$$GET1^DIQ(45.7,IEN,9999999.01)
IF CODE="00"
QUIT
+10 ;
+11 SET COUNT=$GET(COUNT)+1
+12 ;service name
SET LINE=$JUSTIFY(COUNT,2)_". "_NAME
+13 ;abbreviation
SET LINE=$$PAD(LINE,32)_$$GET1^DIQ(45.7,IEN,99)
+14 SET LINE=$$PAD(LINE,39)_CODE
+15 ;hos service
SET LINE=$$PAD(LINE,45)_$$SRV(IEN)
+16 ;active date
SET LINE=$$PAD(LINE,61)_$$LASTDATE(IEN)
+17 DO SET(LINE,COUNT,IEN,.VALMCNT)
End DoDot:2
End DoDot:1
+18 ;
+19 IF '$DATA(^TMP("BDGSYS2",$JOB))
Begin DoDot:1
+20 DO SET("*** NO ENTRIES FOUND WITH IHS CODES!! ***",0,0,.VALMCNT)
End DoDot:1
+21 QUIT
+22 ;
LASTDATE(N) ; find latest effective date and active status
+1 NEW X,Y
+2 ;admitting service?
IF $$GET1^DIQ(45.7,N,9999999.03)'="YES"
QUIT ""
+3 SET X=$ORDER(^DIC(45.7,N,"E","ADATE",""))
IF X=""
QUIT "No effective date"
+4 SET Y=$ORDER(^DIC(45.7,N,"E","ADATE",X,0))
IF 'Y
QUIT "Bad entry"
+5 ;active?
IF $$GET1^DIQ(45.702,Y_","_N,.02)'="YES"
QUIT "Inactive"
+6 QUIT "YES - "_$$PAD($$FMTE^XLFDT(-X),14)
+7 ;
SRV(N) ; returns hospital service for entry
+1 QUIT $EXTRACT($PIECE($$GET1^DIQ(45.7,IEN,2)," SERVICE"),1,15)
+2 ;
SET(DATA,NUM,N,LINE) ; put display line into array
+1 SET LINE=LINE+1
+2 SET ^TMP("BDGSYS2",$JOB,LINE,0)=DATA
+3 SET ^TMP("BDGSYS2",$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("BDGSYS2",$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 ;
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("BDGSYS2",$JOB,"IDX",Y))
IF Y=""
QUIT
Begin DoDot:2
+7 SET Z=$ORDER(^TMP("BDGSYS2",$JOB,"IDX",Y,0))
+8 IF ^TMP("BDGSYS2",$JOB,"IDX",Y,Z)=""
QUIT
+9 IF Z=X
SET BDGN=^TMP("BDGSYS2",$JOB,"IDX",Y,Z)
End DoDot:2
End DoDot:1
+10 ;
+11 IF 'BDGN
DO RESET
QUIT
+12 SET DDSFILE=45.7
SET DA=BDGN
SET DR="[BDG 45.7 SETUP]"
DO ^DDS
+13 DO RESET
+14 QUIT
+15 ;
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)
