Index: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m
===================================================================
--- WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m	(revision 623)
@@ -1,260 +1,247 @@
-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
+IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
+ ;;2.0;INTEGRATED BILLING;**320,348**;21-MAR-94;Build 5
+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,IBLCT,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(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)
+ Q
+ ;
+HELP ; -- help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;
+EXIT ; -- exit code
+ D CLEAN^VALM10
+ 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,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"
+ D ^DIC
+ 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,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 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)))"
+ D ^DIC
+ I Y'>0 G CHANGEQ
+ S IBDIV=+Y
+ ;
+ S DIC("A")="Enter the Care Unit name: "
+ S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
+ D ^DIC
+ I Y<1 G CHANGEQ
+ ;
+ S DA=+Y,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,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)))"
+ D ^DIC
+ I Y'>0 G DELQ
+ S IBDIV=+Y
+ ;
+ K DIC
+ S DIC("A")="Enter the Care Unit name: "
+ S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
+ D ^DIC
+ I Y<1 G DELQ
+ S CAREUNIT=+Y
+ ;
+ 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
+ ;
