| 1 | IBDFCG1 ;ALB/MAF - CONT. of Clinic Group Enter Edit Screen - 1 1 95
|
|---|
| 2 | ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
|
|---|
| 3 | ;
|
|---|
| 4 | ;
|
|---|
| 5 | CLIN ; -- Loop thru all clinics in the clinic group to list alphabetically
|
|---|
| 6 | F IBDCL=0:0 S IBDCL=$O(^IBD(357.99,IBDIFN,10,IBDCL)) Q:'IBDCL I $D(^IBD(357.99,IBDIFN,10,+IBDCL,0)) S X=+^(0),^TMP("IBMF",$J,IBDIFN,"C",$P(^SC(X,0),"^",1),X)=$P(^SC(X,0),"^",1)
|
|---|
| 7 | Q
|
|---|
| 8 | ;
|
|---|
| 9 | ;
|
|---|
| 10 | CLIN1 ; -- Reset the clinic array
|
|---|
| 11 | S IBDCL=$O(^TMP("IBMF",$J,IBDIFN,"C",IBDCL)) S:IBDCL']"" IBDFCFLG=1 Q:IBDCL']"" S IBDFCIEN=$O(^TMP("IBMF",$J,IBDIFN,"C",IBDCL,0)) I IBDFCIEN S ^TMP("IBMF",$J,IBDIFN,IBDFX,"C",IBDFCIEN)=IBDCL
|
|---|
| 12 | Q
|
|---|
| 13 | ;
|
|---|
| 14 | ;
|
|---|
| 15 | DIV ; -- Loop thru all the division that are in a clinic group to list alphabetically
|
|---|
| 16 | F IBDDV=0:0 S IBDDV=$O(^IBD(357.99,IBDIFN,11,IBDDV)) Q:'IBDDV I $D(^IBD(357.99,IBDIFN,11,+IBDDV,0)) S X=+^(0),^TMP("IBMF",$J,IBDIFN,"D",$P(^DG(40.8,X,0),"^",1),X)=$P(^DG(40.8,X,0),"^",1)
|
|---|
| 17 | Q
|
|---|
| 18 | ;
|
|---|
| 19 | ;
|
|---|
| 20 | DIV1 ; -- Reset the division array
|
|---|
| 21 | S IBDDV=$O(^TMP("IBMF",$J,IBDIFN,"D",IBDDV)) S:IBDDV']"" IBDFDFLG=1 Q:IBDDV']"" S IBDFDIEN=$O(^TMP("IBMF",$J,IBDIFN,"D",IBDDV,0)) I IBDFDIEN S ^TMP("IBMF",$J,IBDIFN,IBDFX,"D",IBDFDIEN)=IBDDV
|
|---|
| 22 | Q
|
|---|
| 23 | ;
|
|---|
| 24 | WILDCARD ; -- parse out a wild card
|
|---|
| 25 | W !,"ADDING CLINIC: ",X,!
|
|---|
| 26 | S X=$E(X,1,($L(X)-1))
|
|---|
| 27 | I X]"" D
|
|---|
| 28 | .N IBCLIN,IBDA,IBCLINIC
|
|---|
| 29 | .S IBCLIN=0
|
|---|
| 30 | .F IBCLINIC=0:0 S IBCLIN=$O(^SC("B",IBCLIN)) Q:IBCLIN']"" I X=$E(IBCLIN,1,$L(X)) D
|
|---|
| 31 | ..S IBDA=$O(^SC("B",IBCLIN,0)) I $D(^SC(IBDA,0)),'$D(^IBD(357.99,DA,10,"B",IBDA)) D
|
|---|
| 32 | ...S IB3=$S($P($G(^IBD(357.99,DA,10,0)),"^",3)]"":$P(^IBD(357.99,DA,10,0),"^",3)+1,1:1),IB4=$S($P($G(^IBD(357.99,DA,10,0)),"^",4)]"":$P(^IBD(357.99,DA,10,0),"^",4)+1,1:1)
|
|---|
| 33 | ...S ^IBD(357.99,DA,10,IB3,0)=IBDA,^IBD(357.99,DA,10,"B",IBDA,IB3)=""
|
|---|
| 34 | ...I $D(^IBD(357.99,DA,10,0)) S $P(^IBD(357.99,DA,10,0),"^",3)=IB3,$P(^IBD(357.99,DA,10,0),"^",4)=IB4
|
|---|
| 35 | ...I '$D(^IBD(357.99,DA,10,0)) S ^IBD(357.99,DA,10,0)="^357.9901PA^"_IB3_"^"_IB4
|
|---|
| 36 | ..;F IBDA=0:0 S IBDA=$O(^SC("B",IBCLIN,IBDA)) Q:'IBDA I $G(^SC("B",IBCLIN,IBDA)) S ^IBD(357.99,D0,10,D1,0)=IBDA,^IBD(357.99,D0,10,"B",D1,0)=""
|
|---|
| 37 | ..Q
|
|---|
