- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFCG1 2063 printed Feb 19, 2025@00:18:31 Page 2
- 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
