IBDFUTL1 ;ALB/MAF - Maintenance Utility cont. ;04/20/95
;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23,51,63,70**;APR 24, 1997;Build 46
;
;
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_")",7)
S X=$$SETSTR^VALM1(IBDFVAL,X,1,7)
S IBDFVAL=IBDFX
S X=$$SETSTR^VALM1(IBDFVAL,X,9,8)
S IBDFVAL=$P(IBDFTMP,"^",3)
S X=$$SETSTR^VALM1(IBDFVAL,X,19,15)
S IBDFVAL=$P(^IBE(357.1,IBDFBLK,0),"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,36,14)
S IBDFVAL=$P(^IBE(357,IBDFORM1,0),"^",1)
S X=$$SETSTR^VALM1(IBDFVAL,X,52,14)
I $D(VAUTC)!($D(VAUTG)) S IBDFVAL=$P(IBDFTMP,"^",6) S X=$$SETSTR^VALM1(IBDFVAL,X,68,14)
;
;
TMP ; -- Set up TMP Array
;IBD*3.0*70 - change ^TMP("IBDCPT,$J) to ^XTMP("IBDCPT"), change ^TMP("CPTIDX,$J) to ^XTMP("CPTIDX")
S ^XTMP("IBDCPT",IBDCNT,0)=$S($G(IBDFCODE)["ICD-10":X,$G(IBDFCODE)["ICD-9":X,1:$$LOWER^VALM1(X))
S ^XTMP("IBDCPT","IDX",VALMCNT,IBDCNT1)=""
S:^XTMP("IBDCPT",IBDCNT,0)'=" " ^XTMP("CPTIDX",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
;IBD*3.0*70 - change ^TMP("IBDCPT,$J) to ^XTMP("IBDCPT"), change ^TMP("CPTIDX,$J) to ^XTMP("CPTIDX")
S ^XTMP("IBDCPT",IBDCNT,0)=$S($G(IBDFCODE)["ICD-10":X,$G(IBDFCODE)["ICD-9":X,1:$$LOWER^VALM1(X))
S ^XTMP("IBDCPT","IDX",VALMCNT,IBDCNT1)=""
Q
;
;
SET ; -- Loop thru to see if codes are valid
N IBDY
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
.....;Variable IBDY set to short description in execution of code.
.....X $G(^IBE(357.6,IBDFINT,11))
.....Q:'$D(X)
.....;;----change to api cpt;dhh
.....I $G(IBDFCODE)="CPT " N XX D
......S XX=$$CPT^ICPTCOD(X)
......;;S IBY=$S(+XX=-1:"",1:$P(XX,"^",3))
......S IBDY=$S($P(XX,U,7)'=1:"",1:$P(XX,"^",3))
.....I $G(IBDFCODE)="Type of Visit " S IBDY=$P($G(^IBE(357.69,X,0)),"^",2)
.....I '$D(VAUTJ(X)),'$D(^TMP("IBDFUTL_TEMP",$J,X)) Q ;Check ^TMP global for ICD-10 wildcard search.
.....S ^TMP("UTIL",$J,IBDFNAME,IBDFX,$P(^IBE(357,IBDFORM,0),"^",1),$P(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$S(IBDY]"":IBDY,1:"INVALID")_"^"_IBDFLST_"^"_IBDFSEL_"^"_$S($D(VAUTC):IBDFNAME,$D(VAUTG):IBDFCLNM,1:"")
....I IBDFACT=2 D
.....S (X,IBDFX)=IBI
.....I '$O(^XTMP("CPTIDX",0)) 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
;IBD*3.0*70 - ensure IBDCNT1 incremented when HEADER^IBDFUTL2 calls and sets ^XTMP("IBDCPT") global data
N IBDHDCT
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
..S:'$D(IBDFSEL) IBDFSEL="" F S IBDFSEL=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL)) Q:IBDFSEL']"" D
...S IBDHDCT=0
...S IBDFTMP=^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL),IBDFORM1=$P(IBDFTMP,"^",1),IBDFBLK=$P(IBDFTMP,"^",2) S:'$D(IBDF(IBDFNAME)) IBDHDCT=1 D
....D:'$D(IBDF(IBDFNAME)) HEADER^IBDFUTL2 D SETARR D:IBDBLK="DIAGNOSIS" SETARR1 S:'IBDCNT#10 IBDCNT1=IBDCNT1+IBDHDCT
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
RFRSHLST ;Refresh list to remove replaced/deleted entries - IBD*3.0*70
N IBDRSH,IBDNCNT,IBDCNT,IBDCNT1,IBDCHK,IBDCHK1
K IBDF D FULL^VALM1 S (IBDNCNT,IBDCNT1,VALMCNT)=0
K ^TMP("CPTIDXR",$J),^TMP("IBDCPTR",$J) D KILL^VALM10()
S IBDRSH=0,IBDNCNT=1,IBDCNT=1 F S IBDRSH=$O(^XTMP("IBDCPT",IBDRSH)) Q:'IBDRSH D
.I ^XTMP("IBDCPT",IBDRSH,0)["*Replaced*"!(^XTMP("IBDCPT",IBDRSH,0)["*Deleted*") Q
.S ^TMP("IBDCPTR",$J,IBDNCNT,0)=^XTMP("IBDCPT",IBDRSH,0) I $E(^TMP("IBDCPTR",$J,IBDNCNT,0),7)=")" D
..S $P(^TMP("IBDCPTR",$J,IBDNCNT,0),")")=$E(" ",1,(6-$L(IBDCNT)))_IBDCNT
..S ^TMP("IBDCPTR",$J,"IDX",IBDNCNT,IBDCNT)=""
..S ^TMP("CPTIDXR",$J,IBDCNT)=^XTMP("CPTIDX",$O(^XTMP("IBDCPT","IDX",IBDRSH,""))),$P(^TMP("CPTIDXR",$J,IBDCNT),U)=IBDNCNT,IBDCNT=IBDCNT+1
.I '$D(^TMP("IBDCPTR",$J,"IDX",IBDNCNT)) S IBDCNT1=IBDCNT-1,^TMP("IBDCPTR",$J,"IDX",IBDNCNT,($S(IBDCNT1:IBDCNT1,1:IBDCNT)))=""
.S IBDNCNT=IBDNCNT+1
K ^XTMP("CPTIDX") M ^XTMP("CPTIDX")=^TMP("CPTIDXR",$J)
K ^XTMP("IBDCPT") M ^XTMP("IBDCPT")=^TMP("IBDCPTR",$J)
S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
S ^XTMP("CPTIDX",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility CPTIDX global"
S IBDCHK=0 F S IBDCHK=$O(^XTMP("IBDCPT",IBDCHK)) Q:'IBDCHK I $E(^XTMP("IBDCPT",IBDCHK,0),7)=")" S IBDCHK1=1 Q
I '$G(IBDCHK1) K ^XTMP("IBDCPT") D NUL^IBDFUTL S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
S VALMBG=1,VALMBCK="R"
K ^TMP("CPTIDXR",$J),^TMP("IBDCPTR",$J)
K IBDF,^TMP("UTIL",$J),^TMP("IBDANT",$J) I $G(IBDCHK1) D INIT^IBDFUTL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFUTL1 8968 printed Dec 13, 2024@02:53:49 Page 2
IBDFUTL1 ;ALB/MAF - Maintenance Utility cont. ;04/20/95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23,51,63,70**;APR 24, 1997;Build 46
+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_")",7)
+5 SET X=$$SETSTR^VALM1(IBDFVAL,X,1,7)
+6 SET IBDFVAL=IBDFX
+7 SET X=$$SETSTR^VALM1(IBDFVAL,X,9,8)
+8 SET IBDFVAL=$PIECE(IBDFTMP,"^",3)
+9 SET X=$$SETSTR^VALM1(IBDFVAL,X,19,15)
+10 SET IBDFVAL=$PIECE(^IBE(357.1,IBDFBLK,0),"^",1)
+11 SET X=$$SETSTR^VALM1(IBDFVAL,X,36,14)
+12 SET IBDFVAL=$PIECE(^IBE(357,IBDFORM1,0),"^",1)
+13 SET X=$$SETSTR^VALM1(IBDFVAL,X,52,14)
+14 IF $DATA(VAUTC)!($DATA(VAUTG))
SET IBDFVAL=$PIECE(IBDFTMP,"^",6)
SET X=$$SETSTR^VALM1(IBDFVAL,X,68,14)
+15 ;
+16 ;
TMP ; -- Set up TMP Array
+1 ;IBD*3.0*70 - change ^TMP("IBDCPT,$J) to ^XTMP("IBDCPT"), change ^TMP("CPTIDX,$J) to ^XTMP("CPTIDX")
+2 SET ^XTMP("IBDCPT",IBDCNT,0)=$SELECT($GET(IBDFCODE)["ICD-10":X,$GET(IBDFCODE)["ICD-9":X,1:$$LOWER^VALM1(X))
+3 SET ^XTMP("IBDCPT","IDX",VALMCNT,IBDCNT1)=""
+4 if ^XTMP("IBDCPT",IBDCNT,0)'=" "
SET ^XTMP("CPTIDX",IBDCNT1)=VALMCNT_"^"_IBDFX_"^"_$PIECE(IBDFTMP,"^",4)_"^"_$PIECE(IBDFTMP,"^",5)_"^"_$PIECE(IBDFTMP,"^",1)_"^"_$PIECE(IBDFTMP,"^",2)
+5 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 ;IBD*3.0*70 - change ^TMP("IBDCPT,$J) to ^XTMP("IBDCPT"), change ^TMP("CPTIDX,$J) to ^XTMP("CPTIDX")
+2 SET ^XTMP("IBDCPT",IBDCNT,0)=$SELECT($GET(IBDFCODE)["ICD-10":X,$GET(IBDFCODE)["ICD-9":X,1:$$LOWER^VALM1(X))
+3 SET ^XTMP("IBDCPT","IDX",VALMCNT,IBDCNT1)=""
+4 QUIT
+5 ;
+6 ;
SET ; -- Loop thru to see if codes are valid
+1 NEW IBDY
+2 FOR IBDFBLK=0:0
SET IBDFBLK=$ORDER(^IBE(357.1,"C",IBDFORM,IBDFBLK))
if 'IBDFBLK
QUIT
Begin DoDot:1
+3 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
+4 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
+5 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)
+6 FOR IBI=IBDFX1,IBDFX2,IBDFX3
IF IBI]""
Begin DoDot:4
+7 IF IBDFACT=1
Begin DoDot:5
+8 SET (X,IBDFX)=IBI
+9 ;Variable IBDY set to short description in execution of code.
+10 XECUTE $GET(^IBE(357.6,IBDFINT,11))
+11 if '$DATA(X)
QUIT
+12 ;;----change to api cpt;dhh
+13 IF $GET(IBDFCODE)="CPT "
NEW XX
Begin DoDot:6
+14 SET XX=$$CPT^ICPTCOD(X)
+15 ;;S IBY=$S(+XX=-1:"",1:$P(XX,"^",3))
+16 SET IBDY=$SELECT($PIECE(XX,U,7)'=1:"",1:$PIECE(XX,"^",3))
End DoDot:6
+17 IF $GET(IBDFCODE)="Type of Visit "
SET IBDY=$PIECE($GET(^IBE(357.69,X,0)),"^",2)
+18 ;Check ^TMP global for ICD-10 wildcard search.
IF '$DATA(VAUTJ(X))
IF '$DATA(^TMP("IBDFUTL_TEMP",$JOB,X))
QUIT
+19 SET ^TMP("UTIL",$JOB,IBDFNAME,IBDFX,$PIECE(^IBE(357,IBDFORM,0),"^",1),$PIECE(^IBE(357.1,IBDFBLK,0),"^",1),IBDFSEL)=IBDFORM_"^"_IBDFBLK_"^"_$SELECT(IBDY]"":IBDY,1:"INVALID")_"^"_IBDFLST_"^"_IBDF
SEL_"^"_$SELECT(...
... $DATA(VAUTC):IBDFNAME,$DATA(VAUTG):IBDFCLNM,1:"")
End DoDot:5
+20 IF IBDFACT=2
Begin DoDot:5
+21 SET (X,IBDFX)=IBI
+22 IF '$ORDER(^XTMP("CPTIDX",0))
XECUTE $GET(^IBE(357.6,IBDFINT,11))
+23 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
+24 QUIT
+25 ;
+26 ;
+27 ; -- Set up alphabetical listing
SET1 SET (IBDFORM1,IBDFBLK,IBDFLG,IBDFX,IBDFNAME,IBDORM,IBDBLK)=0
+1 ;IBD*3.0*70 - ensure IBDCNT1 incremented when HEADER^IBDFUTL2 calls and sets ^XTMP("IBDCPT") global data
+2 NEW IBDHDCT
+3 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
+4 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
+5 if '$DATA(IBDFSEL)
SET IBDFSEL=""
FOR
SET IBDFSEL=$ORDER(^TMP("UTIL",$JOB,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL))
if IBDFSEL']""
QUIT
Begin DoDot:3
+6 SET IBDHDCT=0
+7 SET IBDFTMP=^TMP("UTIL",$JOB,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL)
SET IBDFORM1=$PIECE(IBDFTMP,"^",1)
SET IBDFBLK=$PIECE(IBDFTMP,"^",2)
if '$DATA(IBDF(IBDFNAME))
SET IBDHDCT=1
Begin DoDot:4
+8 if '$DATA(IBDF(IBDFNAME))
DO HEADER^IBDFUTL2
DO SETARR
if IBDBLK="DIAGNOSIS"
DO SETARR1
if 'IBDCNT#10
SET IBDCNT1=IBDCNT1+IBDHDCT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
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
RFRSHLST ;Refresh list to remove replaced/deleted entries - IBD*3.0*70
+1 NEW IBDRSH,IBDNCNT,IBDCNT,IBDCNT1,IBDCHK,IBDCHK1
+2 KILL IBDF
DO FULL^VALM1
SET (IBDNCNT,IBDCNT1,VALMCNT)=0
+3 KILL ^TMP("CPTIDXR",$JOB),^TMP("IBDCPTR",$JOB)
DO KILL^VALM10()
+4 SET IBDRSH=0
SET IBDNCNT=1
SET IBDCNT=1
FOR
SET IBDRSH=$ORDER(^XTMP("IBDCPT",IBDRSH))
if 'IBDRSH
QUIT
Begin DoDot:1
+5 IF ^XTMP("IBDCPT",IBDRSH,0)["*Replaced*"!(^XTMP("IBDCPT",IBDRSH,0)["*Deleted*")
QUIT
+6 SET ^TMP("IBDCPTR",$JOB,IBDNCNT,0)=^XTMP("IBDCPT",IBDRSH,0)
IF $EXTRACT(^TMP("IBDCPTR",$JOB,IBDNCNT,0),7)=")"
Begin DoDot:2
+7 SET $PIECE(^TMP("IBDCPTR",$JOB,IBDNCNT,0),")")=$EXTRACT(" ",1,(6-$LENGTH(IBDCNT)))_IBDCNT
+8 SET ^TMP("IBDCPTR",$JOB,"IDX",IBDNCNT,IBDCNT)=""
+9 SET ^TMP("CPTIDXR",$JOB,IBDCNT)=^XTMP("CPTIDX",$ORDER(^XTMP("IBDCPT","IDX",IBDRSH,"")))
SET $PIECE(^TMP("CPTIDXR",$JOB,IBDCNT),U)=IBDNCNT
SET IBDCNT=IBDCNT+1
End DoDot:2
+10 IF '$DATA(^TMP("IBDCPTR",$JOB,"IDX",IBDNCNT))
SET IBDCNT1=IBDCNT-1
SET ^TMP("IBDCPTR",$JOB,"IDX",IBDNCNT,($SELECT(IBDCNT1:IBDCNT1,1:IBDCNT)))=""
+11 SET IBDNCNT=IBDNCNT+1
End DoDot:1
+12 KILL ^XTMP("CPTIDX")
MERGE ^XTMP("CPTIDX")=^TMP("CPTIDXR",$JOB)
+13 KILL ^XTMP("IBDCPT")
MERGE ^XTMP("IBDCPT")=^TMP("IBDCPTR",$JOB)
+14 SET ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
+15 SET ^XTMP("CPTIDX",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility CPTIDX global"
+16 SET IBDCHK=0
FOR
SET IBDCHK=$ORDER(^XTMP("IBDCPT",IBDCHK))
if 'IBDCHK
QUIT
IF $EXTRACT(^XTMP("IBDCPT",IBDCHK,0),7)=")"
SET IBDCHK1=1
QUIT
+17 IF '$GET(IBDCHK1)
KILL ^XTMP("IBDCPT")
DO NUL^IBDFUTL
SET ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
+18 SET VALMBG=1
SET VALMBCK="R"
+19 KILL ^TMP("CPTIDXR",$JOB),^TMP("IBDCPTR",$JOB)
+20 KILL IBDF,^TMP("UTIL",$JOB),^TMP("IBDANT",$JOB)
IF $GET(IBDCHK1)
DO INIT^IBDFUTL
+21 QUIT
