IBDFCG1.m

IBDFCG1 ;ALB/MAF - CONT. of Clinic Group Enter Edit Screen - 1 1 95

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 ;

 ;

CLIN ; -- Loop thru all clinics in the clinic group to list alphabetically

 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)

 Q

 ;

 ;

CLIN1 ;  -- Reset the clinic array

 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

 Q

 ;

 ;

DIV ; -- Loop thru all the division that are in a clinic group to list alphabetically

 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)

 Q

 ;

 ;

DIV1 ;  -- Reset the division array

 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

 Q

 ;

WILDCARD ; -- parse out a wild card

 W !,"ADDING CLINIC: ",X,!

 S X=$E(X,1,($L(X)-1))

 I X]"" D

 .N IBCLIN,IBDA,IBCLINIC

 .S IBCLIN=0

 .F IBCLINIC=0:0 S IBCLIN=$O(^SC("B",IBCLIN)) Q:IBCLIN']""  I X=$E(IBCLIN,1,$L(X)) D

 ..S IBDA=$O(^SC("B",IBCLIN,0)) I $D(^SC(IBDA,0)),'$D(^IBD(357.99,DA,10,"B",IBDA)) D

 ...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)

 ...S ^IBD(357.99,DA,10,IB3,0)=IBDA,^IBD(357.99,DA,10,"B",IBDA,IB3)=""

 ...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

 ...I '$D(^IBD(357.99,DA,10,0)) S ^IBD(357.99,DA,10,0)="^357.9901PA^"_IB3_"^"_IB4

 ..;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)=""

 ..Q

IBDFCG1   ;ALB/MAF - CONT. of Clinic Group Enter Edit Screen - 1 1 95

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

 +3       ;

CLIN      ; -- Loop thru all clinics in the clinic group to list alphabetically

 +1        FOR IBDCL=0:0

               SET IBDCL=$ORDER(^IBD(357.99,IBDIFN,10,IBDCL))

               IF 'IBDCL

                   QUIT 

               IF $DATA(^IBD(357.99,IBDIFN,10,+IBDCL,0))

                   SET X=+^(0)

                   SET ^TMP("IBMF",$JOB,IBDIFN,"C",$PIECE(^SC(X,0),"^",1),X)=$PIECE(^SC(X,0),"^",1)

 +2        QUIT 

 +3       ;

 +4       ;

CLIN1     ;  -- Reset the clinic array

 +1        SET IBDCL=$ORDER(^TMP("IBMF",$JOB,IBDIFN,"C",IBDCL))

           IF IBDCL']""

               SET IBDFCFLG=1

           IF IBDCL']""

               QUIT 

           SET IBDFCIEN=$ORDER(^TMP("IBMF",$JOB,IBDIFN,"C",IBDCL,0))

           IF IBDFCIEN

               SET ^TMP("IBMF",$JOB,IBDIFN,IBDFX,"C",IBDFCIEN)=IBDCL

 +2        QUIT 

 +3       ;

 +4       ;

DIV       ; -- Loop thru all the division that are in a clinic group to list alphabetically

 +1        FOR IBDDV=0:0

               SET IBDDV=$ORDER(^IBD(357.99,IBDIFN,11,IBDDV))

               IF 'IBDDV

                   QUIT 

               IF $DATA(^IBD(357.99,IBDIFN,11,+IBDDV,0))

                   SET X=+^(0)

                   SET ^TMP("IBMF",$JOB,IBDIFN,"D",$PIECE(^DG(40.8,X,0),"^",1),X)=$PIECE(^DG(40.8,X,0),"^",1)

 +2        QUIT 

 +3       ;

 +4       ;

DIV1      ;  -- Reset the division array

 +1        SET IBDDV=$ORDER(^TMP("IBMF",$JOB,IBDIFN,"D",IBDDV))

           IF IBDDV']""

               SET IBDFDFLG=1

           IF IBDDV']""

               QUIT 

           SET IBDFDIEN=$ORDER(^TMP("IBMF",$JOB,IBDIFN,"D",IBDDV,0))

           IF IBDFDIEN

               SET ^TMP("IBMF",$JOB,IBDIFN,IBDFX,"D",IBDFDIEN)=IBDDV

 +2        QUIT 

 +3       ;

WILDCARD  ; -- parse out a wild card

 +1        WRITE !,"ADDING CLINIC: ",X,!

 +2        SET X=$EXTRACT(X,1,($LENGTH(X)-1))

 +3        IF X]""

               Begin DoDot:1

 +4                NEW IBCLIN,IBDA,IBCLINIC

 +5                SET IBCLIN=0

 +6                FOR IBCLINIC=0:0

                       SET IBCLIN=$ORDER(^SC("B",IBCLIN))

                       IF IBCLIN']""

                           QUIT 

                       IF X=$EXTRACT(IBCLIN,1,$LENGTH(X))

                           Begin DoDot:2

 +7                            SET IBDA=$ORDER(^SC("B",IBCLIN,0))

                               IF $DATA(^SC(IBDA,0))

                                   IF '$DATA(^IBD(357.99,DA,10,"B",IBDA))

                                       Begin DoDot:3

 +8                                        SET IB3=$SELECT($PIECE($GET(^IBD(357.99,DA,10,0)),"^",3)]"":$PIECE(^IBD(357.99,DA,10,0),"^",3)+1,1:1)

                                           SET IB4=$SELECT($PIECE($GET(^IBD(357.99,DA,10,0)),"^",4)]"":$PIECE(^IBD(357.99,DA,10,0),"^",4)+1,1:1)

 +9                                        SET ^IBD(357.99,DA,10,IB3,0)=IBDA

                                           SET ^IBD(357.99,DA,10,"B",IBDA,IB3)=""

 +10                                       IF $DATA(^IBD(357.99,DA,10,0))

                                               SET $PIECE(^IBD(357.99,DA,10,0),"^",3)=IB3

                                               SET $PIECE(^IBD(357.99,DA,10,0),"^",4)=IB4

 +11                                       IF '$DATA(^IBD(357.99,DA,10,0))

                                               SET ^IBD(357.99,DA,10,0)="^357.9901PA^"_IB3_"^"_IB4

                                       End DoDot:3

 +12      ;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)=""

 +13                           QUIT 

                           End DoDot:2

               End DoDot:1