BDGICSET ;IHS/OIT/LJF - SET UP DATES FOR USE UNDER ICE;
;;5.3;PIMS;**1004,1005**;MAY 28, 2004
;IHS/OIT/LJF 09/08/2005 PATCH 1004 New routine
;IHS/OIT/LJF 04/20/2006 PATCH 1005 added STAFF subroutine
; added display of medical staff
;
EN ; -- main entry point for BDG IC SETUP ICE
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IC SETUP ICE")
Q
;
HDR ; -- header code
NEW X S X=$$GET1^DIQ(4,DUZ(2),.01)
S VALMHDR(1)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW FAC,LINE,FIELD
S VALMCNT=0 K ^TMP("BDGICSET",$J)
S FAC=$O(^BDGPAR("B",+$$DIV^BSDU,0)) I 'FAC D NONE Q
;
F FIELD=.08,.12,201,.07,.13,202:1:208 D
. S LINE=" "_$$PAD($$LABEL(FIELD)_":",50)_$$GET1^DIQ(9009020.1,FAC,FIELD)
. D SET(LINE,.VALMCNT)
. I FIELD=.13 D SET("",.VALMCNT)
. I FIELD=206 D SET($$PAD(" DATE CHART COMPLETED USED IN ICE"_":",51)_"REQUIRED",.VALMCNT)
;
;IHS/OIT/LJF 04/20/2006 PATCH 1005 added display of medical staff for IC reports
D SET("",.VALMCNT),SET("",.VALMCNT)
D SET($$SP(10)_"*** MEDICAL STAFF INCLUDED ON SCREENED IC REPORTS ***",.VALMCNT)
NEW IEN,CLASS,INACTIVE
S IEN=0 F S IEN=$O(^BDGPAR(FAC,3,IEN)) Q:'IEN D
. S PRV=$$GET1^DIQ(9009020.13,IEN_","_FAC,.01,"I")
. S CLASS=$$PAD($E($$GET1^DIQ(200,PRV,53.5),1,20),23)
. S INACTIVE=$$GET1^DIQ(200,PRV,53.4) I INACTIVE]"" S INACTIVE="Inactivated on "_INACTIVE
. D SET($$PAD($E($$GET1^DIQ(200,PRV,.01),1,27),30)_CLASS_INACTIVE,.VALMCNT)
;end of PATCH 1005 new code
;
NONE ; if none found
I '$D(^TMP("BDGICSET",$J)) D
. S VALMCNT=1
. S ^TMP("BDGICSET",$J,1,0)=$$SP(15)_"NO INFORMATION FOUND - CALL COMPUTER SUPPORT"
Q
;
LABEL(FIELD) ; returns field's title or label
NEW X
S X=$$GET1^DID(9009020.1,FIELD,"","TITLE")
I X="" S X=$$GET1^DID(9009020.1,FIELD,"","LABEL")
Q X
;
SET(DATA,COUNT) ; put data into display line
S COUNT=COUNT+1
S ^TMP("BDGICSET",$J,COUNT,0)=DATA
Q
;
EDIT ;EP; called by BDG IS SETUP EDIT protocol
D FULL^VALM1
NEW DIE,DA,DR
S DA=$O(^BDGPAR("B",+$$DIV^BSDU,0))
I DA S DIE="^BDGPAR(",DR=".08;.12;201;.07;.13;202:208" D ^DIE
S VALMBCK="R" D TERM^VALM0,HDR,INIT
Q
;
;IHS/OIT/LJF 04/20/2006 PATCH 1005 added this subroutine
STAFF ;EP; called by BDG IC MED STAFF protocol
D FULL^VALM1
S DA=$O(^BDGPAR("B",+$$DIV^BSDU,0))
S DIE="^BDGPAR(",DR="3" D ^DIE
S VALMBCK="R" D TERM^VALM0,HDR,INIT
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGICSET",$J)
Q
;
EXPND ; -- expand code
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)
BDGICSET ;IHS/OIT/LJF - SET UP DATES FOR USE UNDER ICE;
+1 ;;5.3;PIMS;**1004,1005**;MAY 28, 2004
+2 ;IHS/OIT/LJF 09/08/2005 PATCH 1004 New routine
+3 ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added STAFF subroutine
+4 ; added display of medical staff
+5 ;
EN ; -- main entry point for BDG IC SETUP ICE
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BDG IC SETUP ICE")
+3 QUIT
+4 ;
HDR ; -- header code
+1 NEW X
SET X=$$GET1^DIQ(4,DUZ(2),.01)
+2 SET VALMHDR(1)=$$SP(75-$LENGTH(X)\2)_X
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 NEW FAC,LINE,FIELD
+2 SET VALMCNT=0
KILL ^TMP("BDGICSET",$JOB)
+3 SET FAC=$ORDER(^BDGPAR("B",+$$DIV^BSDU,0))
IF 'FAC
DO NONE
QUIT
+4 ;
+5 FOR FIELD=.08,.12,201,.07,.13,202:1:208
Begin DoDot:1
+6 SET LINE=" "_$$PAD($$LABEL(FIELD)_":",50)_$$GET1^DIQ(9009020.1,FAC,FIELD)
+7 DO SET(LINE,.VALMCNT)
+8 IF FIELD=.13
DO SET("",.VALMCNT)
+9 IF FIELD=206
DO SET($$PAD(" DATE CHART COMPLETED USED IN ICE"_":",51)_"REQUIRED",.VALMCNT)
End DoDot:1
+10 ;
+11 ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added display of medical staff for IC reports
+12 DO SET("",.VALMCNT)
DO SET("",.VALMCNT)
+13 DO SET($$SP(10)_"*** MEDICAL STAFF INCLUDED ON SCREENED IC REPORTS ***",.VALMCNT)
+14 NEW IEN,CLASS,INACTIVE
+15 SET IEN=0
FOR
SET IEN=$ORDER(^BDGPAR(FAC,3,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+16 SET PRV=$$GET1^DIQ(9009020.13,IEN_","_FAC,.01,"I")
+17 SET CLASS=$$PAD($EXTRACT($$GET1^DIQ(200,PRV,53.5),1,20),23)
+18 SET INACTIVE=$$GET1^DIQ(200,PRV,53.4)
IF INACTIVE]""
SET INACTIVE="Inactivated on "_INACTIVE
+19 DO SET($$PAD($EXTRACT($$GET1^DIQ(200,PRV,.01),1,27),30)_CLASS_INACTIVE,.VALMCNT)
End DoDot:1
+20 ;end of PATCH 1005 new code
+21 ;
NONE ; if none found
+1 IF '$DATA(^TMP("BDGICSET",$JOB))
Begin DoDot:1
+2 SET VALMCNT=1
+3 SET ^TMP("BDGICSET",$JOB,1,0)=$$SP(15)_"NO INFORMATION FOUND - CALL COMPUTER SUPPORT"
End DoDot:1
+4 QUIT
+5 ;
LABEL(FIELD) ; returns field's title or label
+1 NEW X
+2 SET X=$$GET1^DID(9009020.1,FIELD,"","TITLE")
+3 IF X=""
SET X=$$GET1^DID(9009020.1,FIELD,"","LABEL")
+4 QUIT X
+5 ;
SET(DATA,COUNT) ; put data into display line
+1 SET COUNT=COUNT+1
+2 SET ^TMP("BDGICSET",$JOB,COUNT,0)=DATA
+3 QUIT
+4 ;
EDIT ;EP; called by BDG IS SETUP EDIT protocol
+1 DO FULL^VALM1
+2 NEW DIE,DA,DR
+3 SET DA=$ORDER(^BDGPAR("B",+$$DIV^BSDU,0))
+4 IF DA
SET DIE="^BDGPAR("
SET DR=".08;.12;201;.07;.13;202:208"
DO ^DIE
+5 SET VALMBCK="R"
DO TERM^VALM0
DO HDR
DO INIT
+6 QUIT
+7 ;
+8 ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added this subroutine
STAFF ;EP; called by BDG IC MED STAFF protocol
+1 DO FULL^VALM1
+2 SET DA=$ORDER(^BDGPAR("B",+$$DIV^BSDU,0))
+3 SET DIE="^BDGPAR("
SET DR="3"
DO ^DIE
+4 SET VALMBCK="R"
DO TERM^VALM0
DO HDR
DO INIT
+5 QUIT
+6 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGICSET",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
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)
