Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFUTL1

IBDFUTL1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
  1. ; S := string
  1. ; V := destination
  1. ; X := @ col X
  1. ; L := # of chars
  1. ;
  1. Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
  1. ;
  1. ;
  1. SETARR ; -- Set up Listman array
  1. S IBDCNT1=IBDCNT1+1
  1. S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=""
  1. S IBDFVAL=$J(IBDCNT1_")",7)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,1,7)
  1. S IBDFVAL=IBDFX
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,9,8)
  1. S IBDFVAL=$P(IBDFTMP,"^",3)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,19,15)
  1. S IBDFVAL=$P(^IBE(357.1,IBDFBLK,0),"^",1)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,36,14)
  1. S IBDFVAL=$P(^IBE(357,IBDFORM1,0),"^",1)
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,52,14)
  1. I $D(VAUTC)!($D(VAUTG)) S IBDFVAL=$P(IBDFTMP,"^",6) S X=$$SETSTR^VALM1(IBDFVAL,X,68,14)
  1. ;
  1. ;
  1. TMP ; -- Set up TMP Array
  1. ;IBD*3.0*70 - change ^TMP("IBDCPT,$J) to ^XTMP("IBDCPT"), change ^TMP("CPTIDX,$J) to ^XTMP("CPTIDX")
  1. S ^XTMP("IBDCPT",IBDCNT,0)=$S($G(IBDFCODE)["ICD-10":X,$G(IBDFCODE)["ICD-9":X,1:$$LOWER^VALM1(X))
  1. S ^XTMP("IBDCPT","IDX",VALMCNT,IBDCNT1)=""
  1. S:^XTMP("IBDCPT",IBDCNT,0)'=" " ^XTMP("CPTIDX",IBDCNT1)=VALMCNT_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)
  1. Q
  1. SETARR1 ; -- Set up Listman array
  1. N IBDPRIM,IBDSELP
  1. S IBDSELP=$P($G(IBDFTMP),"^",5)
  1. Q:IBDSELP']""
  1. S IBDPRIM=$P($G(^IBE(357.3,IBDSELP,0)),"^")
  1. I IBDPRIM=IBDFX Q
  1. ;S IBDCNT1=IBDCNT1+1
  1. S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=""
  1. S IBDFVAL="Primary Diagnosis: "_IBDPRIM
  1. S X=$$SETSTR^VALM1(IBDFVAL,X,17,40)
  1. ;
  1. ;
  1. TMP1 ; -- Set up TMP Array
  1. ;IBD*3.0*70 - change ^TMP("IBDCPT,$J) to ^XTMP("IBDCPT"), change ^TMP("CPTIDX,$J) to ^XTMP("CPTIDX")
  1. S ^XTMP("IBDCPT",IBDCNT,0)=$S($G(IBDFCODE)["ICD-10":X,$G(IBDFCODE)["ICD-9":X,1:$$LOWER^VALM1(X))
  1. S ^XTMP("IBDCPT","IDX",VALMCNT,IBDCNT1)=""
  1. Q
  1. ;
  1. ;
  1. SET ; -- Loop thru to see if codes are valid
  1. N IBDY
  1. F IBDFBLK=0:0 S IBDFBLK=$O(^IBE(357.1,"C",IBDFORM,IBDFBLK)) Q:'IBDFBLK D
  1. .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
  1. ..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
  1. ...S IBDFX1=$P(IBDFX,"^",1),IBDFX2=$P($G(^IBE(357.3,IBDFSEL,2)),"^",3),IBDFX3=$P($G(^IBE(357.3,IBDFSEL,2)),"^",4)
  1. ...F IBI=IBDFX1,IBDFX2,IBDFX3 I IBI]"" D
  1. ....I IBDFACT=1 D
  1. .....S (X,IBDFX)=IBI
  1. .....;Variable IBDY set to short description in execution of code.
  1. .....X $G(^IBE(357.6,IBDFINT,11))
  1. .....Q:'$D(X)
  1. .....;;----change to api cpt;dhh
  1. .....I $G(IBDFCODE)="CPT " N XX D
  1. ......S XX=$$CPT^ICPTCOD(X)
  1. ......;;S IBY=$S(+XX=-1:"",1:$P(XX,"^",3))
  1. ......S IBDY=$S($P(XX,U,7)'=1:"",1:$P(XX,"^",3))
  1. .....I $G(IBDFCODE)="Type of Visit " S IBDY=$P($G(^IBE(357.69,X,0)),"^",2)
  1. .....I '$D(VAUTJ(X)),'$D(^TMP("IBDFUTL_TEMP",$J,X)) Q ;Check ^TMP global for ICD-10 wildcard search.
  1. .....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:"")
  1. ....I IBDFACT=2 D
  1. .....S (X,IBDFX)=IBI
  1. .....I '$O(^XTMP("CPTIDX",0)) X $G(^IBE(357.6,IBDFINT,11))
  1. .....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:"")
  1. Q
  1. ;
  1. ;
  1. ; -- Set up alphabetical listing
  1. SET1 S (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
  1. N IBDHDCT
  1. 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
  1. .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
  1. ..S:'$D(IBDFSEL) IBDFSEL="" F S IBDFSEL=$O(^TMP("UTIL",$J,IBDFNAME,IBDFX,IBDORM,IBDBLK,IBDFSEL)) Q:IBDFSEL']"" D
  1. ...S IBDHDCT=0
  1. ...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
  1. ....D:'$D(IBDF(IBDFNAME)) HEADER^IBDFUTL2 D SETARR D:IBDBLK="DIAGNOSIS" SETARR1 S:'IBDCNT#10 IBDCNT1=IBDCNT1+IBDHDCT
  1. Q
  1. ;
  1. ;
  1. CLIN1 ; -- Sort Display by clinic
  1. N IBDFBLK,IBDFLST,IBDFORM,VAUTF
  1. 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)
  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
  1. I '$D(IBDFNCNG) K ^TMP("CLN1",$J)
  1. 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
  1. 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
  1. .F IBDFN=2:1:9 S IBDFORM=$P(IBDCNODE,"^",IBDFN) I IBDFORM D SET
  1. D SET1 Q
  1. ;
  1. ;
  1. FORM1 ; -- Sort Display by form
  1. N IBDFBLK,IBDFLST,IBDFORM
  1. 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
  1. I '$D(IBDFNCNG) K ^TMP("FRM1",$J)
  1. 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
  1. 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
  1. D SET1
  1. Q
  1. ;
  1. ;
  1. GROUP1 ; -- Sort Display by clinic group
  1. N IBDFBLK,IBDFLST,IBDFORM,VAUTF
  1. 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
  1. I VAUTG=0,'$D(IBDFNCNG) K ^TMP("GRP1",$J)
  1. I VAUTG=0 F IBDFGIFN=0:0 S IBDFGIFN=$O(VAUTG(IBDFGIFN)) Q:'IBDFGIFN S ^TMP("GRP1",$J,VAUTG(IBDFGIFN))=IBDFGIFN
  1. S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("GRP1",$J,IBDFGNM)) Q:IBDFGNM']"" S IBDFGIFN=^TMP("GRP1",$J,IBDFGNM) D
  1. .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
  1. .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)=""
  1. D:$D(^TMP("IBDF",$J,"D")) ENDV^IBDFUTL2
  1. 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
  1. .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
  1. D SET1 Q
  1. RFRSHLST ;Refresh list to remove replaced/deleted entries - IBD*3.0*70
  1. N IBDRSH,IBDNCNT,IBDCNT,IBDCNT1,IBDCHK,IBDCHK1
  1. K IBDF D FULL^VALM1 S (IBDNCNT,IBDCNT1,VALMCNT)=0
  1. K ^TMP("CPTIDXR",$J),^TMP("IBDCPTR",$J) D KILL^VALM10()
  1. S IBDRSH=0,IBDNCNT=1,IBDCNT=1 F S IBDRSH=$O(^XTMP("IBDCPT",IBDRSH)) Q:'IBDRSH D
  1. .I ^XTMP("IBDCPT",IBDRSH,0)["*Replaced*"!(^XTMP("IBDCPT",IBDRSH,0)["*Deleted*") Q
  1. .S ^TMP("IBDCPTR",$J,IBDNCNT,0)=^XTMP("IBDCPT",IBDRSH,0) I $E(^TMP("IBDCPTR",$J,IBDNCNT,0),7)=")" D
  1. ..S $P(^TMP("IBDCPTR",$J,IBDNCNT,0),")")=$E(" ",1,(6-$L(IBDCNT)))_IBDCNT
  1. ..S ^TMP("IBDCPTR",$J,"IDX",IBDNCNT,IBDCNT)=""
  1. ..S ^TMP("CPTIDXR",$J,IBDCNT)=^XTMP("CPTIDX",$O(^XTMP("IBDCPT","IDX",IBDRSH,""))),$P(^TMP("CPTIDXR",$J,IBDCNT),U)=IBDNCNT,IBDCNT=IBDCNT+1
  1. .I '$D(^TMP("IBDCPTR",$J,"IDX",IBDNCNT)) S IBDCNT1=IBDCNT-1,^TMP("IBDCPTR",$J,"IDX",IBDNCNT,($S(IBDCNT1:IBDCNT1,1:IBDCNT)))=""
  1. .S IBDNCNT=IBDNCNT+1
  1. K ^XTMP("CPTIDX") M ^XTMP("CPTIDX")=^TMP("CPTIDXR",$J)
  1. K ^XTMP("IBDCPT") M ^XTMP("IBDCPT")=^TMP("IBDCPTR",$J)
  1. S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
  1. S ^XTMP("CPTIDX",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility CPTIDX global"
  1. S IBDCHK=0 F S IBDCHK=$O(^XTMP("IBDCPT",IBDCHK)) Q:'IBDCHK I $E(^XTMP("IBDCPT",IBDCHK,0),7)=")" S IBDCHK1=1 Q
  1. I '$G(IBDCHK1) K ^XTMP("IBDCPT") D NUL^IBDFUTL S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
  1. S VALMBG=1,VALMBCK="R"
  1. K ^TMP("CPTIDXR",$J),^TMP("IBDCPTR",$J)
  1. K IBDF,^TMP("UTIL",$J),^TMP("IBDANT",$J) I $G(IBDCHK1) D INIT^IBDFUTL
  1. Q