IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
Q
;
HDR ; -- header code
K VALMHDR
S VALMHDR(1)=" "
S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL")
Q
;
INIT ; -- init variables and list array
N DIR,Y
I '$G(IBINS) D I +Y<0 S VALMQUIT=1 Q
. S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT) S Y=-2 Q
. I Y>0 S IBINS=+Y Q
;
D BLD
Q
;
BLD ;
D CLEAN^VALM10
K ^TMP("IBPRV_CU",$J)
N TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN
;
S VALMBG=1
;
; Get all care units for this insurance company that have a division
; If there is no division, then it is part of the other care units code (IBCEP4)
;
S SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS"
D LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR")
;
I '+TAR("DILIST",0) D
. D SET^VALM10(1,"No CARE UNITs found for this Insurance Company")
;
I +TAR("DILIST",0) D
. S IBCT=0
. F VALMCNT=1:1:+TAR("DILIST",0) D
.. S ^TMP("IBPRV_CU",$J,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT
. S DIV="" F S DIV=$O(^TMP("IBPRV_CU",$J,"SORT",DIV)) Q:DIV="" D
.. S Z="Division: "_DIV
.. S IBCT=IBCT+1
.. D SET^VALM10(IBCT,Z)
.. S D0=0 F S D0=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,D0)) Q:'D0 D
... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0)
... S Z=$J("",2)
... S Z=Z_$E(IN_" ",1,4)_$E(TAR("DILIST","ID",IN,.01),1,36)
... S Z=Z_$J("",40-$L(Z))
... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38)
... S IBCT=IBCT+1
... D SET^VALM10(IBCT,Z)
;
; correct the VALMCNT variable - number of lines in the list (not entries)
S VALMCNT=+$O(@VALMAR@(""),-1)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAN^VALM10
K ^TMP("IBPRV_CU",$J)
Q
;
EXPND ; -- expand code
Q
;
NEW ; Add care unit
; Assumes IBINS is defined as ins co ien (file 36)
; IB = 0 or null if called from list manager, 1 if not
N DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
;
D FULL^VALM1
; Add an entry - either new care unit/ins co or a combination for
; existing care unit/ins co
;
S MAIN=$$MAIN^IBCEP2B()
S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ"
S D="B^C"
D MIX^DIC1
I Y'>0 G NEWQ
S IBDIV=+Y
S IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV)
;
N SCREEN,TAR,MESS,I
S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
D LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR")
;
ACU K DIR
S I=0
I $G(TAR("DILIST",0)) D
. S DIR("?",1)="Current Entries are:"
. F I=2:1 Q:'$D(TAR("DILIST",1,I-1)) S DIR("?",I)=" "_TAR("DILIST",1,I-1)
. S DIR("?",I)=" "
;
S DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company."
S DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for"
S DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor."
S DIR("A")="Enter the Care Unit name"
S DIR(0)="FO^1:30"
D ^DIR
I X=""!$G(DUOUT)!$G(DTOUT)!$G(DIROUT) G NEWQ
S CAREUNIT=X
;
; At this point, we have X and it'a not a ? or ^
;
K DIC
S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="EX"
D ^DIC
;
; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units)
I Y>0 D G ACU
. D DISPMESS("This action is for adding new entries, not editing existing entries.")
;
; New entry , validate field
N TAR2
D FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2")
S X=CAREUNIT
X TAR2("INPUT TRANSFORM")
I '$D(X) D G ACU ; Failed input transform
. D DISPMESS("Invalid Format.")
;
K DIR
S DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'"
S DIR("B")="N"
S DIR(0)="Y"
D ^DIR
I Y=0 G ACU
I Y["^" G NEWQ
;
; If it got this far, we have an exact match or a new entry.
S X=CAREUNIT
S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="XL",DLAYGO=355.95
S DIC("DR")=".03////"_+$G(IBINS)_";.04////"_$G(IBDIV)
D ^DIC
I Y>0 D
. S DA=+Y,DIE="^IBA(355.95,"
. S DR=".02Enter the Care Unit Description"
. D ^DIE
D BLD
;
NEWQ S VALMBCK="R"
Q
;
CHANGE ; Edit care unit
; Assumes IBINS is defined as ins co ien (file 36)
;
D FULL^VALM1
;
N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I
;
S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
;
I '+$G(TAR("DILIST",0)) D G CHANGEQ
.D DISPMESS("No Care Units Defined for this insurance company.")
;
; Store all Divisons with at least one care unit in DIVISION array
F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D
. S DIVISION(TAR("DILIST","ID",I,.04))=""
;
; Only allow divisions that have care units to be selected
S DIC=40.8
S DIC("A")="Enter the Division for this Care Unit: "
S DIC(0)="AEMQ"
S DIC("S")="I $D(DIVISION($P(^(0),U)))"
S D="B^C"
D MIX^DIC1
I Y'>0 G CHANGEQ
S IBDIV=+Y
S DA=$$SEL($P(Y,U,2)) I 'DA G CHANGEQ
S DIE=355.95
S DR=".01Care Unit;.04Division;.02Description"
D ^DIE
;
D BLD
;
CHANGEQ S VALMBCK="R"
Q
;
DEL ; Delete a Care Unit
; Assumes IBINS is defined as ins co ien (file 36)
;
D FULL^VALM1
N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
;
S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
;
I '+$G(TAR("DILIST",0)) D G DELQ
.D DISPMESS("No Care Units Defined for this insurance company.")
;
; Store all Divisons with at least one care unit in DIVISION array
F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D
. S DIVISION(TAR("DILIST","ID",I,.04))=""
;
; Only allow divisions that have care units to be selected
S DIC=40.8
S DIC("A")="Enter the Division for this Care Unit: "
S DIC(0)="AEMQ"
S DIC("S")="I $D(DIVISION($P(^(0),U)))"
S D="B^C"
D MIX^DIC1
I Y'>0 G DELQ
S IBDIV=+Y
S CAREUNIT=$$SEL($P(Y,U,2)) I 'CAREUNIT G DELQ
;
I $D(^IBA(355.92,"AC",+Y)) D G DELQ
. S DIR(0)="EA"
. S DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be"
. S DIR("A",2)="deleted before deleting the Care Unit."
. S DIR("A")="Press return to continue "
. W ! D ^DIR K DIR
;
S DIR("A")="OK to Delete: "
S DIR("B")="No"
S DIR(0)="YAO"
D ^DIR
I '$G(Y) G DELQ
K DIR
;
S DA=CAREUNIT
S DIK="^IBA("_355.95_","
D ^DIK
;
D BLD
;
DELQ S VALMBCK="R"
Q
;
DISPMESS(MESS) ;
N DIR,X,Y
S DIR(0)="EA",DIR("A",1)=MESS
S DIR("A")="PRESS ENTER to continue "
D ^DIR
Q
;
SEL(DIV) ; select care unit for a given division
; DIV - name of division
; returns ien of selected care unit, or 0 if nothing is selected
N DIR,I,IEN,MIN,MAX,X,Y
I $G(DIV)="" Q 0
S IEN=0
S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,"")),MIN=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,""),-1),MAX=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
I MIN=MAX S IEN=I
I MIN'=MAX D
.S DIR("A")="Select CARE UNITS",DIR(0)="N^"_MIN_":"_MAX_":0" D ^DIR
.Q:$D(DTOUT)!$D(DUOUT)
.S I="" F S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) Q:I=""!(IEN>0) S:$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))=Y IEN=I
.Q
Q IEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEPA 7701 printed Sep 02, 2024@18:57:10 Page 2
IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
+1 ;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
+1 DO EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
+2 QUIT
+3 ;
HDR ; -- header code
+1 KILL VALMHDR
+2 SET VALMHDR(1)=" "
+3 SET VALMHDR(2)="Insurance Co: "_$SELECT('$GET(IBALL)&$GET(IBINS):$PIECE($GET(^DIC(36,+IBINS,0)),U),1:"ALL")
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 NEW DIR,Y
+2 IF '$GET(IBINS)
Begin DoDot:1
+3 SET DIR(0)="PA^DIC(36,:AEMQ"
SET DIR("A")="Select INSURANCE CO: "
SET DIR("?")="Select an INSURANCE CO to display its care units"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=-2
QUIT
+6 IF Y>0
SET IBINS=+Y
QUIT
End DoDot:1
IF +Y<0
SET VALMQUIT=1
QUIT
+7 ;
+8 DO BLD
+9 QUIT
+10 ;
BLD ;
+1 DO CLEAN^VALM10
+2 KILL ^TMP("IBPRV_CU",$JOB)
+3 NEW TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN
+4 ;
+5 SET VALMBG=1
+6 ;
+7 ; Get all care units for this insurance company that have a division
+8 ; If there is no division, then it is part of the other care units code (IBCEP4)
+9 ;
+10 SET SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS"
+11 DO LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR")
+12 ;
+13 IF '+TAR("DILIST",0)
Begin DoDot:1
+14 DO SET^VALM10(1,"No CARE UNITs found for this Insurance Company")
End DoDot:1
+15 ;
+16 IF +TAR("DILIST",0)
Begin DoDot:1
+17 SET IBCT=0
+18 FOR VALMCNT=1:1:+TAR("DILIST",0)
Begin DoDot:2
+19 SET ^TMP("IBPRV_CU",$JOB,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT
End DoDot:2
+20 SET DIV=""
FOR
SET DIV=$ORDER(^TMP("IBPRV_CU",$JOB,"SORT",DIV))
if DIV=""
QUIT
Begin DoDot:2
+21 SET Z="Division: "_DIV
+22 SET IBCT=IBCT+1
+23 DO SET^VALM10(IBCT,Z)
+24 SET D0=0
FOR
SET D0=$ORDER(^TMP("IBPRV_CU",$JOB,"SORT",DIV,D0))
if 'D0
QUIT
Begin DoDot:3
+25 SET IN=^TMP("IBPRV_CU",$JOB,"SORT",DIV,D0)
+26 SET Z=$JUSTIFY("",2)
+27 SET Z=Z_$EXTRACT(IN_" ",1,4)_$EXTRACT(TAR("DILIST","ID",IN,.01),1,36)
+28 SET Z=Z_$JUSTIFY("",40-$LENGTH(Z))
+29 SET Z=Z_$EXTRACT(TAR("DILIST","ID",IN,.02),1,38)
+30 SET IBCT=IBCT+1
+31 DO SET^VALM10(IBCT,Z)
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ; correct the VALMCNT variable - number of lines in the list (not entries)
+34 SET VALMCNT=+$ORDER(@VALMAR@(""),-1)
+35 QUIT
+36 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAN^VALM10
+2 KILL ^TMP("IBPRV_CU",$JOB)
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
NEW ; Add care unit
+1 ; Assumes IBINS is defined as ins co ien (file 36)
+2 ; IB = 0 or null if called from list manager, 1 if not
+3 NEW DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
+4 ;
+5 DO FULL^VALM1
+6 ; Add an entry - either new care unit/ins co or a combination for
+7 ; existing care unit/ins co
+8 ;
+9 SET MAIN=$$MAIN^IBCEP2B()
+10 SET MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
+11 SET DIC=40.8
SET DIC("A")="Enter the Division for this Care Unit: "
SET DIC("B")=MAIN
SET DIC(0)="AEMQ"
+12 SET D="B^C"
+13 DO MIX^DIC1
+14 IF Y'>0
GOTO NEWQ
+15 SET IBDIV=+Y
+16 SET IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV)
+17 ;
+18 NEW SCREEN,TAR,MESS,I
+19 SET SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
+20 DO LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR")
+21 ;
ACU KILL DIR
+1 SET I=0
+2 IF $GET(TAR("DILIST",0))
Begin DoDot:1
+3 SET DIR("?",1)="Current Entries are:"
+4 FOR I=2:1
if '$DATA(TAR("DILIST",1,I-1))
QUIT
SET DIR("?",I)=" "_TAR("DILIST",1,I-1)
+5 SET DIR("?",I)=" "
End DoDot:1
+6 ;
+7 SET DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company."
+8 SET DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for"
+9 SET DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor."
+10 SET DIR("A")="Enter the Care Unit name"
+11 SET DIR(0)="FO^1:30"
+12 DO ^DIR
+13 IF X=""!$GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT)
GOTO NEWQ
+14 SET CAREUNIT=X
+15 ;
+16 ; At this point, we have X and it'a not a ? or ^
+17 ;
+18 KILL DIC
+19 SET DIC="^IBA(355.95,"
SET DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
SET DIC(0)="EX"
+20 DO ^DIC
+21 ;
+22 ; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units)
+23 IF Y>0
Begin DoDot:1
+24 DO DISPMESS("This action is for adding new entries, not editing existing entries.")
End DoDot:1
GOTO ACU
+25 ;
+26 ; New entry , validate field
+27 NEW TAR2
+28 DO FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2")
+29 SET X=CAREUNIT
+30 XECUTE TAR2("INPUT TRANSFORM")
+31 ; Failed input transform
IF '$DATA(X)
Begin DoDot:1
+32 DO DISPMESS("Invalid Format.")
End DoDot:1
GOTO ACU
+33 ;
+34 KILL DIR
+35 SET DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'"
+36 SET DIR("B")="N"
+37 SET DIR(0)="Y"
+38 DO ^DIR
+39 IF Y=0
GOTO ACU
+40 IF Y["^"
GOTO NEWQ
+41 ;
+42 ; If it got this far, we have an exact match or a new entry.
+43 SET X=CAREUNIT
+44 SET DIC="^IBA(355.95,"
SET DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
SET DIC(0)="XL"
SET DLAYGO=355.95
+45 SET DIC("DR")=".03////"_+$GET(IBINS)_";.04////"_$GET(IBDIV)
+46 DO ^DIC
+47 IF Y>0
Begin DoDot:1
+48 SET DA=+Y
SET DIE="^IBA(355.95,"
+49 SET DR=".02Enter the Care Unit Description"
+50 DO ^DIE
End DoDot:1
+51 DO BLD
+52 ;
NEWQ SET VALMBCK="R"
+1 QUIT
+2 ;
CHANGE ; Edit care unit
+1 ; Assumes IBINS is defined as ins co ien (file 36)
+2 ;
+3 DO FULL^VALM1
+4 ;
+5 NEW X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I
+6 ;
+7 SET SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
+8 DO LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
+9 ;
+10 IF '+$GET(TAR("DILIST",0))
Begin DoDot:1
+11 DO DISPMESS("No Care Units Defined for this insurance company.")
End DoDot:1
GOTO CHANGEQ
+12 ;
+13 ; Store all Divisons with at least one care unit in DIVISION array
+14 FOR I=1:1
if '$DATA(TAR("DILIST","ID",I,.04))
QUIT
Begin DoDot:1
+15 SET DIVISION(TAR("DILIST","ID",I,.04))=""
End DoDot:1
+16 ;
+17 ; Only allow divisions that have care units to be selected
+18 SET DIC=40.8
+19 SET DIC("A")="Enter the Division for this Care Unit: "
+20 SET DIC(0)="AEMQ"
+21 SET DIC("S")="I $D(DIVISION($P(^(0),U)))"
+22 SET D="B^C"
+23 DO MIX^DIC1
+24 IF Y'>0
GOTO CHANGEQ
+25 SET IBDIV=+Y
+26 SET DA=$$SEL($PIECE(Y,U,2))
IF 'DA
GOTO CHANGEQ
+27 SET DIE=355.95
+28 SET DR=".01Care Unit;.04Division;.02Description"
+29 DO ^DIE
+30 ;
+31 DO BLD
+32 ;
CHANGEQ SET VALMBCK="R"
+1 QUIT
+2 ;
DEL ; Delete a Care Unit
+1 ; Assumes IBINS is defined as ins co ien (file 36)
+2 ;
+3 DO FULL^VALM1
+4 NEW X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
+5 ;
+6 SET SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
+7 DO LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
+8 ;
+9 IF '+$GET(TAR("DILIST",0))
Begin DoDot:1
+10 DO DISPMESS("No Care Units Defined for this insurance company.")
End DoDot:1
GOTO DELQ
+11 ;
+12 ; Store all Divisons with at least one care unit in DIVISION array
+13 FOR I=1:1
if '$DATA(TAR("DILIST","ID",I,.04))
QUIT
Begin DoDot:1
+14 SET DIVISION(TAR("DILIST","ID",I,.04))=""
End DoDot:1
+15 ;
+16 ; Only allow divisions that have care units to be selected
+17 SET DIC=40.8
+18 SET DIC("A")="Enter the Division for this Care Unit: "
+19 SET DIC(0)="AEMQ"
+20 SET DIC("S")="I $D(DIVISION($P(^(0),U)))"
+21 SET D="B^C"
+22 DO MIX^DIC1
+23 IF Y'>0
GOTO DELQ
+24 SET IBDIV=+Y
+25 SET CAREUNIT=$$SEL($PIECE(Y,U,2))
IF 'CAREUNIT
GOTO DELQ
+26 ;
+27 IF $DATA(^IBA(355.92,"AC",+Y))
Begin DoDot:1
+28 SET DIR(0)="EA"
+29 SET DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be"
+30 SET DIR("A",2)="deleted before deleting the Care Unit."
+31 SET DIR("A")="Press return to continue "
+32 WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO DELQ
+33 ;
+34 SET DIR("A")="OK to Delete: "
+35 SET DIR("B")="No"
+36 SET DIR(0)="YAO"
+37 DO ^DIR
+38 IF '$GET(Y)
GOTO DELQ
+39 KILL DIR
+40 ;
+41 SET DA=CAREUNIT
+42 SET DIK="^IBA("_355.95_","
+43 DO ^DIK
+44 ;
+45 DO BLD
+46 ;
DELQ SET VALMBCK="R"
+1 QUIT
+2 ;
DISPMESS(MESS) ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="EA"
SET DIR("A",1)=MESS
+3 SET DIR("A")="PRESS ENTER to continue "
+4 DO ^DIR
+5 QUIT
+6 ;
SEL(DIV) ; select care unit for a given division
+1 ; DIV - name of division
+2 ; returns ien of selected care unit, or 0 if nothing is selected
+3 NEW DIR,I,IEN,MIN,MAX,X,Y
+4 IF $GET(DIV)=""
QUIT 0
+5 SET IEN=0
+6 SET I=$ORDER(^TMP("IBPRV_CU",$JOB,"SORT",DIV,""))
SET MIN=$GET(^TMP("IBPRV_CU",$JOB,"SORT",DIV,I))
+7 SET I=$ORDER(^TMP("IBPRV_CU",$JOB,"SORT",DIV,""),-1)
SET MAX=$GET(^TMP("IBPRV_CU",$JOB,"SORT",DIV,I))
+8 IF MIN=MAX
SET IEN=I
+9 IF MIN'=MAX
Begin DoDot:1
+10 SET DIR("A")="Select CARE UNITS"
SET DIR(0)="N^"_MIN_":"_MAX_":0"
DO ^DIR
+11 if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+12 SET I=""
FOR
SET I=$ORDER(^TMP("IBPRV_CU",$JOB,"SORT",DIV,I))
if I=""!(IEN>0)
QUIT
if $GET(^TMP("IBPRV_CU",$JOB,"SORT",DIV,I))=Y
SET IEN=I
+13 QUIT
End DoDot:1
+14 QUIT IEN
