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

IBDFUTL2.m

Go to the documentation of this file.
  1. IBDFUTL2 ;ALB/MAF - MAINTENANCE UTILITY CONT. ;4/24/95
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,63,70**;APR 24, 1997;Build 46
  1. ;
  1. ;
  1. ;
  1. ENDV ; -- Entire divisions were chosen, find all clinics (with encounter forms defined)
  1. N IBCLN,IBDIV,NODE,DIVISION,ALL
  1. ; -- Make a list of the divisions chosen
  1. S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("IBDF",$J,"D",IBDFGNM)) Q:IBDFGNM']"" S IBDIV=0 F S IBDIV=$O(^TMP("IBDF",$J,"D",IBDFGNM,IBDIV)) Q:'IBDIV S DIVISION(IBDIV,IBDFGNM)=""
  1. ;
  1. ; -- Loop through all the clinics finding ones in selected divisions
  1. S IBCLN="" F S IBCLN=$O(^SC(IBCLN)) Q:IBCLN="" D
  1. .S NODE=$G(^SC(IBCLN,0))
  1. .S IBDIV=$P(NODE,"^",15)
  1. .I IBDIV Q:'$D(DIVISION(IBDIV))
  1. .; -- Check that location is a clinic
  1. .Q:$P(NODE,"^",3)'="C"
  1. .; -- It passed all the tests, put it on the list
  1. .S IBDNAM=0 F IBDFDIV=0:0 S IBDFDIV=$O(DIVISION(IBDFDIV)) Q:'IBDFDIV I IBDFDIV=IBDIV F IBDNAME=0:0 S IBDNAM=$O(DIVISION(IBDFDIV,IBDNAM)) Q:IBDNAM']"" S ^TMP("IBDF",$J,"C",IBDNAM,$P(^SC(IBCLN,0),"^",1))=IBCLN
  1. ;
  1. ; -- Don't need list of divisions anymore
  1. K ^TMP("IBDF",$J,"D")
  1. Q
  1. ;
  1. ;
  1. CLINICS ; -- Clinics that use the form
  1. N IBDFFLG
  1. S IBDFFLG=0 F IDX="C","D","E","F","G","H","I","J" D
  1. .S SETUP="" F S SETUP=$O(^SD(409.95,IDX,IBDFORM1,SETUP)) Q:'SETUP D
  1. ..S CLINIC=$P($G(^SD(409.95,SETUP,0)),"^",1)
  1. ..Q:'CLINIC
  1. ..S NAME=$P($G(^SC(CLINIC,0)),"^",1)
  1. ..Q:NAME=""
  1. ..I IBDFFLG S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. ..D:'IBDFFLG TMP1 S:IBDFFLG X="" S X=$$SETSTR^VALM1($E(NAME,1,20),X,66,14) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,37,29,IOINHI,IOINORM,0) S IBDFFLG=1
  1. Q
  1. ;
  1. ;
  1. TMP1 ; -- Text display set up of TMP array
  1. S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=$$SETSTR^VALM1(" ",X,1,80) D TMP^IBDFUTL1
  1. S X="",X=$$SETSTR^VALM1("CLINICS USING THIS FORM ARE: ",X,37,29)
  1. Q
  1. ;
  1. ;
  1. I VALMCNT>0 N IBXFL S IBXFL=$S(VALMCNT+1/14?1.6N:1,VALMCNT+2/14?1.6N:2,VALMCNT+3/14?1.6N:3,VALMCNT+4/14?1.6N:4,1:0) I IBXFL D
  1. .N IBXFL1
  1. .F IBXFL1=1:1:IBXFL D
  1. ..S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
  1. S IBDCNT1=IBDCNT1+1
  1. S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=""
  1. S IBDF(IBDFNAME)=IBDCNT_"^"_IBDFORM1,^XTMP("IBDF",IBDFNAME)=IBDCNT_"^"_IBDFORM1
  1. S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
  1. S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S IBDVAL=IBDFNAME
  1. S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
  1. S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
  1. S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1. S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
  1. S IBDCNT1=IBDCNT1-1
  1. Q
  1. ;
  1. ;
  1. JUMP ; -- Jump action to display a specific clinic group on the screen.
  1. D FULL^VALM1
  1. I $D(XQORNOD(0)),$P(XQORNOD(0),"^",4)]"" S X=$P(XQORNOD(0),"^",4) S X=$P(X,"=",2) I X]"" D:X?1.6N JSEL S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="QEZ" D ^DIC K DIC G:Y<0 JMP S Y=+Y D JUMP1 Q
  1. JMP S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="AEMN",DIC("A")="Select "_$S($D(VAUTF):"Form",$D(VAUTG):"Clinic Group",1:"Clinic")_" you wish to move to: "
  1. S:$D(VAUTC) DIC("S")="I $P(^SC(+Y,0),U,3)=""C""" D ^DIC K DIC
  1. I X["^" S VALMBG=1,VALMBCK="R" Q
  1. ;
  1. ;
  1. JUMP1 I Y<0 G JUMP
  1. N IBDFCAT
  1. S IBDFCAT=$S($D(VAUTF):$P(^IBE(357,+Y,0),"^",1),$D(VAUTG):$P(^IBD(357.99,+Y,0),"^",1),1:$P(^SC(+Y,0),"^",1))
  1. I '$D(IBDF(IBDFCAT)) W !!,"There is no data listed for this Clinic Group" G JMP
  1. S VALMBG=+IBDF(IBDFCAT) S VALMBCK="R" Q
  1. Q
  1. ;
  1. ;
  1. JSEL ; -- Convert number selected to name
  1. S IBDVALM=X I $D(^TMP("CGIDX",$J,IBDVALM)) S X=$P(^TMP("CGIDX",$J,IBDVALM),"^",2),X=$P(^IBD(357.99,X,0),"^",1)
  1. Q
  1. ;
  1. ;
  1. CHGLST ; -- Code to change list display
  1. D FULL^VALM1
  1. S IBDFDIS1=IBDFDIS,IBDFINT1=IBDFINT,IBDFACT1=IBDFACT
  1. D EXIT1^IBDFUTL,OUT^IBDFUTL
  1. Q
  1. ;
  1. ;
  1. DELETE ; -- Delete invalid code from the selection list/block
  1. N IBDFVALM,VALMY,IBBLK,IBFORM,DA,IBDN,IBDX,IBD9,IBD10,IBDIEN,IBDINV,IBDTMP1
  1. S VALMBCK=""
  1. D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDFVALM=0
  1. D FULL^VALM1 S VALMBCK="R"
  1. F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" D Q:$G(IBDINV)=1
  1. .I $G(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($G(^XTMP("CPTIDX",IBDFVALM))="*Deleted*") S IBDINV=1 W !,"Not a valid selection; selection has already been replaced or deleted." H 3 Q
  1. .S DA=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",4) I DA]"" S IBFORM=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",5),IBBLK=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",6) D
  1. ..S DIK="^IBE(357.3,",DA=DA,IBDIEN(DA)="" D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
  1. ..S IBDTMP1=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^")
  1. ..S ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Deleted*******",^XTMP("IBDCPT","IDX",IBDTMP1)="",^XTMP("CPTIDX",IBDFVALM)="*Deleted*"
  1. Q:$G(IBDINV)=1
  1. K IBDF,^TMP("UTIL",$J)
  1. S IBDN="",(IBD9,IBD10)=0 F S IBDN=$O(^IBE(357.2,"C",IBBLK,IBDN)) Q:IBDN="" S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
  1. .I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE" S IBD9=1
  1. .I IBDX="DG SELECT ICD-10 DIAGNOSIS COD" S IBD10=1
  1. ;Now update history if ICD-9 or ICD-10 was present before or after the change
  1. N IBDX
  1. I IBD9 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
  1. I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
  1. ; -- Redo list
  1. REP K IBDF D INIT^IBDFUTL S VALMBG=1,VALMBCK="R"
  1. Q
  1. DLTALL ; -- Delete invalid code from the selection list/block
  1. N IBDFVALM,VALMY,IBBLK,IBFORM,DA,IBDN,IBDX,IBD9,IBD10,IBDIEN,IBDICD,IBDY,IBDTMP1,IBDINV
  1. S VALMBCK=""
  1. D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDFVALM=0
  1. D FULL^VALM1 S VALMBCK="R"
  1. F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" D Q:$G(IBDINV)=1
  1. .I $G(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($G(^XTMP("CPTIDX",IBDFVALM))="*Deleted*") S IBDINV=1 W !,"Not a valid selection; selection has already been replaced or deleted." H 3 Q
  1. .S DA=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",4) I DA]"" D
  1. ..S IBDICD=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",2) S IBDY=0 F S IBDY=$O(^XTMP("CPTIDX",IBDY)) Q:'IBDY I $P($G(^XTMP("CPTIDX",IBDY)),"^",2)=IBDICD D
  1. ...S IBFORM=$P($G(^XTMP("CPTIDX",IBDY)),"^",5),IBBLK=$P($G(^XTMP("CPTIDX",IBDY)),"^",6),IBDTMP1=$P($G(^XTMP("CPTIDX",IBDY)),"^")
  1. ...S DIK="^IBE(357.3,",DA=$P($G(^XTMP("CPTIDX",IBDY)),"^",4),IBDIEN(DA)="" D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
  1. ...S ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Deleted*******",^XTMP("IBDCPT","IDX",IBDTMP1)="",^XTMP("CPTIDX",IBDY)="*Deleted*"
  1. Q:$G(IBDINV)=1
  1. K IBDF,^TMP("UTIL",$J)
  1. S IBDN="",(IBD9,IBD10)=0 F S IBDN=$O(^IBE(357.2,"C",IBBLK,IBDN)) Q:IBDN="" S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
  1. .I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE" S IBD9=1
  1. .I IBDX="DG SELECT ICD-10 DIAGNOSIS COD" S IBD10=1
  1. ;Now update history if ICD-9 or ICD-10 was present before or after the change
  1. N IBDX
  1. I IBD9 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
  1. I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
  1. K IBDF D INIT^IBDFUTL S VALMBCK="R"
  1. Q