IBDFUTL1 ;ALB/MAF - Maintenance Utility cont. - 4 20 95
;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23**;APR 24, 1997
;
;
SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
; S := string
; V := destination
; X := @ col X
; L := # of chars
;
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
;
;
SETARR ; -- Set up Listman array
S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDFVAL=$J(IBDCNT1_")",5)
S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
S IBDFVAL=IBDFX
S X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
S IBDFVAL=$P(IBDFTMP,"^",3)
S X=$$SETSTR^VALM1(IBDFVAL,X,17,15)
S IBDFVAL=$P(^IBE(357.1,IBDFBLK,0),"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,34,14)
S IBDFVAL=$P(^IBE(357,IBDFORM1,0),"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,50,14)
I $D(VAUTC)!($D(VAUTG)) S IBDFVAL=$P(IBDFTMP,"^",6) S X=$$SETSTR^VALM1(IBDFVAL,X,66,14)
;
;
TMP ; -- Set up TMP Array
S ^TMP("CPT",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("CPT",$J,"IDX",VALMCNT,IBDCNT1)=""
S ^TMP("CPTIDX",$J,IBDCNT1)=VALMCNT_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)
Q
SETARR1 ; -- Set up Listman array
N IBDPRIM,IBDSELP
S IBDSELP=$P($G(IBDFTMP),"^",5)
Q:IBDSELP']""
S IBDPRIM=$P($G(^IBE(357.3,IBDSELP,0)),"^")
I IBDPRIM=IBDFX Q
;S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDFVAL="Primary Diagnosis: "_IBDPRIM
S X=$$SETSTR^VALM1(IBDFVAL,X,17,40)
;
;
TMP1 ; -- Set up TMP Array
S ^TMP("CPT",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("CPT",$J,"IDX",VALMCNT,IBDCNT1)=""
Q
;
;
SET ; -- Loop thru to see if codes are valid
F IBDFBLK=0:0 S IBDFBLK=$O(^IBE(357.1,"C",IBDFORM,IBDFBLK)) Q:'IBDFBLK D
.F IBDFLST=0:0 S IBDFLST=$O(^IBE(357.2,"C",IBDFBLK,IBDFLST)) Q:'IBDFLST S IBDFNODE=$G(^IBE(357.2,IBDFLST,0)) I $P(IBDFNODE,"^",11)=IBDFINT D
..F IBDFSEL=0:0 S IBDFSEL=$O(^IBE(357.3,"C",IBDFLST,IBDFSEL)) Q:'IBDFSEL S IBDFX=$G(^IBE(357.3,IBDFSEL,0)) I $P(IBDFX,"^",2)']"" D
...S IBDFX1=$P(IBDFX,"^",1),IBDFX2=$P($G(^IBE(357.3,IBDFSEL,2)),"^",3),IBDFX3=$P($G(^IBE(357.3,IBDFSEL,2)),"^",4)
...F IBI=IBDFX1,IBDFX2,IBDFX3 I IBI]"" D
....I IBDFACT=1 D
.....S (X,IBDFX)=IBI
.....X $G(^IBE(357.6,IBDFINT,11))
.....Q:'$D(X)
.....;;----change to api cpt;dhh
.....I $G(IBDFCODE)="CPT " N IBY,XX D
......S XX=$$CPT^ICPTCOD(X)
......S IBY=$S(+XX=-1:"",1:$P(XX,"^",3))
.....I $G(IBDFCODE)="ICD-9 " N IBY S IBY=$P($G(^ICD9(X,0)),"^",3)
.....I $G(IBDFCODE)="Type of Visit " N IBY S IBY=$P($G(^IBE(357.69,X,0)),"^",2)
.....Q:'$D(VAUTJ(X))
.....S ^TMP("UTIL",$J,IBDFNAME,IBDFX,$P(^IBE(357,IBDFORM,0),"^",1),$P(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$S(IBY]"":IBY,1:"INVALID")_"^"_IBDFLST_"^"_IBDFSEL_"^"_$S($D(VAUTC):IBDFNAME,$D(VAUTG):IBDFCLNM,1:"")
....I IBDFACT=2 D
.....S (X,IBDFX)=IBI
.....X $G(^IBE(357.6,IBDFINT,11))
.....I '$D(X) S ^TMP("UTIL",$J,IBDFNAME,IBDFX,$P(^IBE(357,IBDFORM,0),"^",1),$P(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$S(Y]"":Y,1:"INVALID")_"^"_IBDFLST_"^"_IBDFSEL_"^"_$S($D(VAUTC):IBDFNAME,$D(VAUTG):IBDFCLNM,1:"")
Q
;
;
; -- Set up alphabetical listing
SET1 S (IBDFORM1,IBDFBLK,IBDFLG,IBDFX,IBDFNAME,IBDORM,IBDBLK)=0
F IBDFNM=0:0 S IBDFNAME=$O(^TMP("UTIL",$J,IBDFNAME)) Q:IBDFNAME']"" S IBDFX="" F S IBDFX=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX)) D:(IBDFX="")&($D(VAUTF)) CLINICS^IBDFUTL2 Q:IBDFX="" D
.F IBDFRM=0:0 S IBDORM=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM)) Q:IBDORM']"" F IBDFBK=0:0 S IBDBLK=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK)) Q:IBDBLK']"" D
..F S IBDFSEL=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL)) Q:IBDFSEL']"" D
...S IBDFTMP=^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL),IBDFORM1=$P(IBDFTMP,"^",1),IBDFBLK=$P(IBDFTMP,"^",2) D:'$D(IBDF(IBDFNAME)) HEADER^IBDFUTL2 D SETARR D:IBDBLK="DIAGNOSIS" SETARR1
Q
;
;
CLIN1 ; -- Sort Display by clinic
N IBDFBLK,IBDFLST,IBDFORM,VAUTF
I VAUTC=1 F X=0:0 S X=$O(^SC(X)) Q:'X I $D(^SC(X,0)) S ^TMP("CLN",$J,X)=$P(^SC(X,0),"^",1)
I VAUTC=0 K ^TMP("CLN",$J) F IBDFCLIN=0:0 S IBDFCLIN=$O(VAUTC(IBDFCLIN)) Q:'IBDFCLIN S X=$G(VAUTC(IBDFCLIN)) S ^TMP("CLN",$J,IBDFCLIN)=X
I '$D(IBDFNCNG) K ^TMP("CLN1",$J)
F IBDFCLIN=0:0 S IBDFCLIN=$O(^TMP("CLN",$J,IBDFCLIN)) Q:'IBDFCLIN S X=$G(^TMP("CLN",$J,IBDFCLIN)) S ^TMP("CLN1",$J,X)=IBDFCLIN
S IBDCLNM=0 F IBDCLN=0:0 S IBDCLNM=$O(^TMP("CLN1",$J,IBDCLNM)) Q:IBDCLNM']"" S IBDFCLIN=^TMP("CLN1",$J,IBDCLNM) S IBDFCIFN=$O(^SD(409.95,"B",IBDFCLIN,0)) S IBDCNODE=$G(^SD(409.95,+IBDFCIFN,0)),IBDFNAME=IBDCLNM I $D(IBDCNODE) D
.F IBDFN=2:1:9 S IBDFORM=$P(IBDCNODE,"^",IBDFN) I IBDFORM D SET
D SET1 Q
;
;
FORM1 ; -- Sort Display by form
N IBDFBLK,IBDFLST,IBDFORM
I VAUTF=1 S IBDFRNM=0 F IBDFRM=0:0 S IBDFRNM=$O(^IBE(357,"B",IBDFRNM)) Q:IBDFRNM']"" F IBDFORM=0:0 S IBDFORM=$O(^IBE(357,"B",IBDFRNM,IBDFORM)) Q:'IBDFORM S IBDFNAME=IBDFRNM D SET
I '$D(IBDFNCNG) K ^TMP("FRM1",$J)
I VAUTF=0 F IBDFORM=0:0 S IBDFORM=$O(VAUTF(IBDFORM)) Q:'IBDFORM S X=$G(VAUTF(IBDFORM)) S ^TMP("FRM1",$J,X)=IBDFORM
I VAUTF=0 S IBDFRNM=0 F IBDFRM=0:0 S IBDFRNM=$O(^TMP("FRM1",$J,IBDFRNM)) Q:IBDFRNM']"" S IBDFORM=^TMP("FRM1",$J,IBDFRNM),IBDFNAME=IBDFRNM D SET
D SET1
Q
;
;
GROUP1 ; -- Sort Display by clinic group
N IBDFBLK,IBDFLST,IBDFORM,VAUTF
I VAUTG=1 S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^IBD(357.99,"B",IBDFGNM)) Q:IBDFGNM']"" F IBDFGIFN=0:0 S IBDFGIFN=$O(^IBD(357.99,"B",IBDFGNM,IBDFGIFN)) Q:'IBDFGIFN S ^TMP("GRP1",$J,IBDFGNM)=IBDFGIFN
I VAUTG=0,'$D(IBDFNCNG) K ^TMP("GRP1",$J)
I VAUTG=0 F IBDFGIFN=0:0 S IBDFGIFN=$O(VAUTG(IBDFGIFN)) Q:'IBDFGIFN S ^TMP("GRP1",$J,VAUTG(IBDFGIFN))=IBDFGIFN
S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("GRP1",$J,IBDFGNM)) Q:IBDFGNM']"" S IBDFGIFN=^TMP("GRP1",$J,IBDFGNM) D
.S IEN=0 F S IEN=$O(^IBD(357.99,IBDFGIFN,10,IEN)) Q:'IEN S IBCLN=+$G(^IBD(357.99,IBDFGIFN,10,IEN,0)) S:$D(^SC(IBCLN,0)) ^TMP("IBDF",$J,"C",IBDFGNM,$P(^SC(IBCLN,0),"^",1))=IBCLN
.S IEN=0 F S IEN=$O(^IBD(357.99,IBDFGIFN,11,IEN)) Q:'IEN S IBDIV=+$G(^IBD(357.99,IBDFGIFN,11,IEN,0)) S:IBDIV ^TMP("IBDF",$J,"D",IBDFGNM,IBDIV)=""
D:$D(^TMP("IBDF",$J,"D")) ENDV^IBDFUTL2
S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("IBDF",$J,"C",IBDFGNM)) Q:IBDFGNM']"" S IBDFCLNM=0 F IBDFCLN=0:0 S IBDFCLNM=$O(^TMP("IBDF",$J,"C",IBDFGNM,IBDFCLNM)) Q:IBDFCLNM']"" D
.S IBDFCLIN=$G(^TMP("IBDF",$J,"C",IBDFGNM,IBDFCLNM)),IBDFCIFN=$O(^SD(409.95,"B",IBDFCLIN,0)) S IBDCNODE=$G(^SD(409.95,+IBDFCIFN,0)) I $D(IBDCNODE) S IBDFNAME=IBDFGNM F IBDFN=2:1:9 S IBDFORM=$P(IBDCNODE,"^",IBDFN) I IBDFORM D SET
D SET1 Q
IBDFUTL1 ;ALB/MAF - Maintenance Utility cont. - 4 20 95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23**;APR 24, 1997
+2 ;
+3 ;
SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
+1 ; S := string
+2 ; V := destination
+3 ; X := @ col X
+4 ; L := # of chars
+5 ;
+6 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
+7 ;
+8 ;
SETARR ; -- Set up Listman array
+1 SET IBDCNT1=IBDCNT1+1
+2 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+3 SET X=""
+4 SET IBDFVAL=$JUSTIFY(IBDCNT1_")",5)
+5 SET X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
+6 SET IBDFVAL=IBDFX
+7 SET X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
+8 SET IBDFVAL=$PIECE(IBDFTMP,"^",3)
+9 SET X=$$SETSTR^VALM1(IBDFVAL,X,17,15)
+10 SET IBDFVAL=$PIECE(^IBE(357.1,IBDFBLK,0),"^",1)
+11 SET X=$$SETSTR^VALM1(IBDFVAL,X,34,14)
+12 SET IBDFVAL=$PIECE(^IBE(357,IBDFORM1,0),"^",1)
+13 SET X=$$SETSTR^VALM1(IBDFVAL,X,50,14)
+14 IF $DATA(VAUTC)!($DATA(VAUTG))
SET IBDFVAL=$PIECE(IBDFTMP,"^",6)
SET X=$$SETSTR^VALM1(IBDFVAL,X,66,14)
+15 ;
+16 ;
TMP ; -- Set up TMP Array
+1 SET ^TMP("CPT",$JOB,IBDCNT,0)=$$LOWER^VALM1(X)
SET ^TMP("CPT",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+2 SET ^TMP("CPTIDX",$JOB,IBDCNT1)=VALMCNT_"^"_IBDFX_"^"_$PIECE(IBDFTMP,"^",4)_"^"_$PIECE(IBDFTMP,"^",5)_"^"_$PIECE(IBDFTMP,"^",1)_"^"_$PIECE(IBDFTMP,"^",2)
+3 QUIT
SETARR1 ; -- Set up Listman array
+1 NEW IBDPRIM,IBDSELP
+2 SET IBDSELP=$PIECE($GET(IBDFTMP),"^",5)
+3 IF IBDSELP']""
QUIT
+4 SET IBDPRIM=$PIECE($GET(^IBE(357.3,IBDSELP,0)),"^")
+5 IF IBDPRIM=IBDFX
QUIT
+6 ;S IBDCNT1=IBDCNT1+1
+7 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+8 SET X=""
+9 SET IBDFVAL="Primary Diagnosis: "_IBDPRIM
+10 SET X=$$SETSTR^VALM1(IBDFVAL,X,17,40)
+11 ;
+12 ;
TMP1 ; -- Set up TMP Array
+1 SET ^TMP("CPT",$JOB,IBDCNT,0)=$$LOWER^VALM1(X)
SET ^TMP("CPT",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+2 QUIT
+3 ;
+4 ;
SET ; -- Loop thru to see if codes are valid
+1 FOR IBDFBLK=0:0
SET IBDFBLK=$ORDER(^IBE(357.1,"C",IBDFORM,IBDFBLK))
IF 'IBDFBLK
QUIT
Begin DoDot:1
+2 FOR IBDFLST=0:0
SET IBDFLST=$ORDER(^IBE(357.2,"C",IBDFBLK,IBDFLST))
IF 'IBDFLST
QUIT
SET IBDFNODE=$GET(^IBE(357.2,IBDFLST,0))
IF $PIECE(IBDFNODE,"^",11)=IBDFINT
Begin DoDot:2
+3 FOR IBDFSEL=0:0
SET IBDFSEL=$ORDER(^IBE(357.3,"C",IBDFLST,IBDFSEL))
IF 'IBDFSEL
QUIT
SET IBDFX=$GET(^IBE(357.3,IBDFSEL,0))
IF $PIECE(IBDFX,"^",2)']""
Begin DoDot:3
+4 SET IBDFX1=$PIECE(IBDFX,"^",1)
SET IBDFX2=$PIECE($GET(^IBE(357.3,IBDFSEL,2)),"^",3)
SET IBDFX3=$PIECE($GET(^IBE(357.3,IBDFSEL,2)),"^",4)
+5 FOR IBI=IBDFX1,IBDFX2,IBDFX3
IF IBI]""
Begin DoDot:4
+6 IF IBDFACT=1
Begin DoDot:5
+7 SET (X,IBDFX)=IBI
+8 XECUTE $GET(^IBE(357.6,IBDFINT,11))
+9 IF '$DATA(X)
QUIT
+10 ;;----change to api cpt;dhh
+11 IF $GET(IBDFCODE)="CPT "
NEW IBY,XX
Begin DoDot:6
+12 SET XX=$$CPT^ICPTCOD(X)
+13 SET IBY=$SELECT(+XX=-1:"",1:$PIECE(XX,"^",3))
End DoDot:6
+14 IF $GET(IBDFCODE)="ICD-9 "
NEW IBY
SET IBY=$PIECE($GET(^ICD9(X,0)),"^",3)
+15 IF $GET(IBDFCODE)="Type of Visit "
NEW IBY
SET IBY=$PIECE($GET(^IBE(357.69,X,0)),"^",2)
+16 IF '$DATA(VAUTJ(X))
QUIT
+17 SET ^TMP("UTIL",$JOB,IBDFNAME,IBDFX,$PIECE(^IBE(357,IBDFORM,0),"^",1),$PIECE(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$SELECT(IBY]"":IBY,1:"INVALID")_"^"_IBDFLST_"^"_IBDFSE
L_"^"_$SELECT(...
... $DATA(VAUTC):IBDFNAME,$DATA(VAUTG):IBDFCLNM,1:"")
End DoDot:5
+18 IF IBDFACT=2
Begin DoDot:5
+19 SET (X,IBDFX)=IBI
+20 XECUTE $GET(^IBE(357.6,IBDFINT,11))
+21 IF '$DATA(X)
SET ^TMP("UTIL",$JOB,IBDFNAME,IBDFX,$PIECE(^IBE(357,IBDFORM,0),"^",1),$PIECE(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$SELECT(Y]"":Y,1:"INVALID")_"^"_IBDFLST_"^"_IBDFS
EL_"^"_$SELECT($DATA(VAUTC):IBDFNAME,$DATA(VAUTG):IBDFCLNM,1:"")
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
+24 ;
+25 ; -- Set up alphabetical listing
SET1 SET (IBDFORM1,IBDFBLK,IBDFLG,IBDFX,IBDFNAME,IBDORM,IBDBLK)=0
+1 FOR IBDFNM=0:0
SET IBDFNAME=$ORDER(^TMP("UTIL",$JOB,IBDFNAME))
IF IBDFNAME']""
QUIT
SET IBDFX=""
FOR
SET IBDFX=$ORDER(^TMP("UTIL",$JOB,IBDFNAME,IBDFX))
IF (IBDFX="")&($DATA(VAUTF))
DO CLINICS^IBDFUTL2
IF IBDFX=""
QUIT
Begin DoDot:1
+2 FOR IBDFRM=0:0
SET IBDORM=$ORDER(^TMP("UTIL",$JOB,IBDFNAME,IBDFX,IBDORM))
IF IBDORM']""
QUIT
FOR IBDFBK=0:0
SET IBDBLK=$ORDER(^TMP("UTIL",$JOB,IBDFNAME,IBDFX,IBDORM,IBDBLK))
IF IBDBLK']""
QUIT
Begin DoDot:2
+3 FOR
SET IBDFSEL=$ORDER(^TMP("UTIL",$JOB,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL))
IF IBDFSEL']""
QUIT
Begin DoDot:3
+4 SET IBDFTMP=^TMP("UTIL",$JOB,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL)
SET IBDFORM1=$PIECE(IBDFTMP,"^",1)
SET IBDFBLK=$PIECE(IBDFTMP,"^",2)
IF '$DATA(IBDF(IBDFNAME))
DO HEADER^IBDFUTL2
DO SETARR
IF IBDBLK="DIAGNOSIS"
DO SETARR1
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
+7 ;
CLIN1 ; -- Sort Display by clinic
+1 NEW IBDFBLK,IBDFLST,IBDFORM,VAUTF
+2 IF VAUTC=1
FOR X=0:0
SET X=$ORDER(^SC(X))
IF 'X
QUIT
IF $DATA(^SC(X,0))
SET ^TMP("CLN",$JOB,X)=$PIECE(^SC(X,0),"^",1)
+3 IF VAUTC=0
KILL ^TMP("CLN",$JOB)
FOR IBDFCLIN=0:0
SET IBDFCLIN=$ORDER(VAUTC(IBDFCLIN))
IF 'IBDFCLIN
QUIT
SET X=$GET(VAUTC(IBDFCLIN))
SET ^TMP("CLN",$JOB,IBDFCLIN)=X
+4 IF '$DATA(IBDFNCNG)
KILL ^TMP("CLN1",$JOB)
+5 FOR IBDFCLIN=0:0
SET IBDFCLIN=$ORDER(^TMP("CLN",$JOB,IBDFCLIN))
IF 'IBDFCLIN
QUIT
SET X=$GET(^TMP("CLN",$JOB,IBDFCLIN))
SET ^TMP("CLN1",$JOB,X)=IBDFCLIN
+6 SET IBDCLNM=0
FOR IBDCLN=0:0
SET IBDCLNM=$ORDER(^TMP("CLN1",$JOB,IBDCLNM))
IF IBDCLNM']""
QUIT
SET IBDFCLIN=^TMP("CLN1",$JOB,IBDCLNM)
SET IBDFCIFN=$ORDER(^SD(409.95,"B",IBDFCLIN,0))
SET IBDCNODE=$GET(^SD(409.95,+IBDFCIFN,0))
SET IBDFNAME=IBDCLNM
IF $DATA(IBDCNODE)
Begin DoDot:1
+7 FOR IBDFN=2:1:9
SET IBDFORM=$PIECE(IBDCNODE,"^",IBDFN)
IF IBDFORM
DO SET
End DoDot:1
+8 DO SET1
QUIT
+9 ;
+10 ;
FORM1 ; -- Sort Display by form
+1 NEW IBDFBLK,IBDFLST,IBDFORM
+2 IF VAUTF=1
SET IBDFRNM=0
FOR IBDFRM=0:0
SET IBDFRNM=$ORDER(^IBE(357,"B",IBDFRNM))
IF IBDFRNM']""
QUIT
FOR IBDFORM=0:0
SET IBDFORM=$ORDER(^IBE(357,"B",IBDFRNM,IBDFORM))
IF 'IBDFORM
QUIT
SET IBDFNAME=IBDFRNM
DO SET
+3 IF '$DATA(IBDFNCNG)
KILL ^TMP("FRM1",$JOB)
+4 IF VAUTF=0
FOR IBDFORM=0:0
SET IBDFORM=$ORDER(VAUTF(IBDFORM))
IF 'IBDFORM
QUIT
SET X=$GET(VAUTF(IBDFORM))
SET ^TMP("FRM1",$JOB,X)=IBDFORM
+5 IF VAUTF=0
SET IBDFRNM=0
FOR IBDFRM=0:0
SET IBDFRNM=$ORDER(^TMP("FRM1",$JOB,IBDFRNM))
IF IBDFRNM']""
QUIT
SET IBDFORM=^TMP("FRM1",$JOB,IBDFRNM)
SET IBDFNAME=IBDFRNM
DO SET
+6 DO SET1
+7 QUIT
+8 ;
+9 ;
GROUP1 ; -- Sort Display by clinic group
+1 NEW IBDFBLK,IBDFLST,IBDFORM,VAUTF
+2 IF VAUTG=1
SET IBDFGNM=0
FOR IBDFGN=0:0
SET IBDFGNM=$ORDER(^IBD(357.99,"B",IBDFGNM))
IF IBDFGNM']""
QUIT
FOR IBDFGIFN=0:0
SET IBDFGIFN=$ORDER(^IBD(357.99,"B",IBDFGNM,IBDFGIFN))
IF 'IBDFGIFN
QUIT
SET ^TMP("GRP1",$JOB,IBDFGNM)=IBDFGIFN
+3 IF VAUTG=0
IF '$DATA(IBDFNCNG)
KILL ^TMP("GRP1",$JOB)
+4 IF VAUTG=0
FOR IBDFGIFN=0:0
SET IBDFGIFN=$ORDER(VAUTG(IBDFGIFN))
IF 'IBDFGIFN
QUIT
SET ^TMP("GRP1",$JOB,VAUTG(IBDFGIFN))=IBDFGIFN
+5 SET IBDFGNM=0
FOR IBDFGN=0:0
SET IBDFGNM=$ORDER(^TMP("GRP1",$JOB,IBDFGNM))
IF IBDFGNM']""
QUIT
SET IBDFGIFN=^TMP("GRP1",$JOB,IBDFGNM)
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^IBD(357.99,IBDFGIFN,10,IEN))
IF 'IEN
QUIT
SET IBCLN=+$GET(^IBD(357.99,IBDFGIFN,10,IEN,0))
IF $DATA(^SC(IBCLN,0))
SET ^TMP("IBDF",$JOB,"C",IBDFGNM,$PIECE(^SC(IBCLN,0),"^",1))=IBCLN
+7 SET IEN=0
FOR
SET IEN=$ORDER(^IBD(357.99,IBDFGIFN,11,IEN))
IF 'IEN
QUIT
SET IBDIV=+$GET(^IBD(357.99,IBDFGIFN,11,IEN,0))
IF IBDIV
SET ^TMP("IBDF",$JOB,"D",IBDFGNM,IBDIV)=""
End DoDot:1
+8 IF $DATA(^TMP("IBDF",$JOB,"D"))
DO ENDV^IBDFUTL2
+9 SET IBDFGNM=0
FOR IBDFGN=0:0
SET IBDFGNM=$ORDER(^TMP("IBDF",$JOB,"C",IBDFGNM))
IF IBDFGNM']""
QUIT
SET IBDFCLNM=0
FOR IBDFCLN=0:0
SET IBDFCLNM=$ORDER(^TMP("IBDF",$JOB,"C",IBDFGNM,IBDFCLNM))
IF IBDFCLNM']""
QUIT
Begin DoDot:1
+10 SET IBDFCLIN=$GET(^TMP("IBDF",$JOB,"C",IBDFGNM,IBDFCLNM))
SET IBDFCIFN=$ORDER(^SD(409.95,"B",IBDFCLIN,0))
SET IBDCNODE=$GET(^SD(409.95,+IBDFCIFN,0))
IF $DATA(IBDCNODE)
SET IBDFNAME=IBDFGNM
FOR IBDFN=2:1:9
SET IBDFORM=$PIECE(IBDCNODE,"^",IBDFN)
IF IBDFORM
DO SET
End DoDot:1
+11 DO SET1
QUIT
