- 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 Feb 19, 2025@00:20:14 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