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

IBDF18E0.m

Go to the documentation of this file. 
  1. IBDF18E0 ;ALB/CJM - ENCOUNTER FORM - PCE DEVICE INTERFACE utilities ;04-OCT-94
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;**11,25,38,36,23,62**;APR 24, 1997;Build 9
  1.  ;
  1. SETPXCA ;set values from TEMP() into the PXCA()
  1.  ;
  1.  N NODE,NUMBER,IBQUIT,Y,Y1,X
  1.  S PROVIDER=+$P(PXCA("ENCOUNTER"),"^",4)
  1.  I PROVIDER,"^P^S^"'[("^"_$P(PXCA("ENCOUNTER"),"^",15)_"^") S $P(PXCA("ENCOUNTER"),"^",15)="S" D LOGERR^IBDF18E2(3579603,.FORMID,"",PROVIDER)
  1.  ;
  1.  S NODE="" F  S NODE=$O(TEMP(NODE)) Q:NODE=""  S NUMBER=0,FID="" F  S FID=$O(TEMP(NODE,FID)) Q:FID=""  S ITEM="" F  S ITEM=$O(TEMP(NODE,FID,ITEM)) Q:ITEM=""  D
  1.  .S IBQUIT=0
  1.  .I NODE="PROCEDURE" S X=TEMP(NODE,FID,ITEM) D
  1.  ..I $P(X,"^",2)="" S $P(X,"^",2)=1
  1.  ..S Y=0 F  S Y=$O(PXCA(NODE,PROVIDER,Y)) Q:'Y!(IBQUIT)  D
  1.  ...S Y1=$G(PXCA(NODE,PROVIDER,Y))
  1.  ...I $P(X,"^")=$P(Y1,"^"),$P(X,"^",3,7)=$P(Y1,"^",3,7) S $P(PXCA(NODE,PROVIDER,Y),"^",2)=$P(PXCA(NODE,PROVIDER,Y),"^",2)+$P(X,"^",2),IBQUIT=1
  1.  ..Q:IBQUIT
  1.  ..S TEMP(NODE,FID,ITEM)=X
  1.  .I IBQUIT K TEMP(NODE,FID,ITEM) Q
  1.  .S NUMBER=NUMBER+1
  1.  .S PXCA(NODE,PROVIDER,NUMBER)=TEMP(NODE,FID,ITEM)
  1.  .I $D(TEMP(NODE,FID,ITEM,"MODIFIER")) D MODPXCA
  1.  .K TEMP(NODE,FID,ITEM)
  1.  ;
  1.  ; -- default c/o date time to now if not passed
  1.  I '$P($G(^IBD(357.09,1,1)),"^",2) D  ;cont only if s/p not answerred
  1.  .I $D(PXCA("ENCOUNTER")) I $P(PXCA("ENCOUNTER"),"^",14)="" D  ;quit if we are already passing c/o date/time
  1.  ..N SDOE S SDOE=$$FNDSDOE^IBDFDE($S(+$G(FORMID("DFN")):+$G(FORMID("DFN")),+$G(IBDF("DFN")):+$G(IBDF("DFN")),1:$G(DFN)),$S(+$G(FORMID("APPT")):+$G(FORMID("APPT")),+$G(IBDF("APPT")):+$G(IBDF("APPT")),1:$G(APPT)))
  1.  ..Q:$$COMDT^SDCOU(+SDOE)  ;c/o already performed, don't overwrite
  1.  ..N IBDDFN,IBDAPPT,IBDCLN,IBDCOST
  1.  ..S IBDDFN=$S(+$G(FORMID("DFN")):+$G(FORMID("DFN")),+$G(IBDF("DFN")):+$G(IBDF("DFN")),1:$G(DFN))
  1.  ..S IBDAPPT=$S(+$G(FORMID("APPT")):+$G(FORMID("APPT")),+$G(IBDF("APPT")):+$G(IBDF("APPT")),1:$G(APPT))
  1.  ..S IBDCLN=$S(+$G(FORMID("CLINIC")):+$G(FORMID("CLINIC")),+$G(IBDF("CLINIC")):+$G(IBDF("CLINIC")),1:$G(CLN))
  1.  ..S IBDCOST=$$STATUS^SDAM1(IBDDFN,IBDAPPT,IBDCLN,$G(^DPT(IBDDFN,0))) Q:$P(IBDCOST,";",5)
  1.  ..S $P(PXCA("ENCOUNTER"),"^",14)=$E($$HTFM^XLFDT($H),1,12)
  1.  ;
  1.  D OTHRBUB
  1.  Q
  1.  ;
  1.  ;
  1. OTHRBUB ; -- check procedure and diagnosis node for other bubble, but no data
  1.  N NODE,CODE,OUT,X,XX
  1.  S I=0 F  S I=$O(PXCA("PROCEDURE",I)) Q:I=""  S J=0 F  S J=$O(PXCA("PROCEDURE",I,J)) Q:J=""  D
  1.  .I +$G(PXCA("PROCEDURE",I,J))<1 D  ;no code, may be treatment
  1.  ..I $P($G(PXCA("PROCEDURE",I,J)),"^",6)["OTHER#" D  ;no code, narr=other
  1.  ...D LOGERR^IBDF18E2(3579612,.FORMID)
  1.  ...K PXCA("PROCEDURE",I,J)
  1.  .I +$G(PXCA("PROCEDURE",I,J)),$P($G(PXCA("PROCEDURE",I,J)),"^",6)["OTHER#" D
  1.  ..;; --change to api cpt ; dhh
  1.  ..S CODE=$$CPT^ICPTCOD(CODE)
  1.  ..S $P(PXCA("PROCEDURE",I,J),"^",6)=$S(+CODE'=-1:$E($P((CODE),"^",3),1,80),1:"")
  1.  ;
  1.  S I=0 F  S I=$O(PXCA("DIAGNOSIS/PROBLEM",I)) Q:I=""  S J=0 F  S J=$O(PXCA("DIAGNOSIS/PROBLEM",I,J)) Q:J=""  D
  1.  .I $P($G(PXCA("DIAGNOSIS/PROBLEM",I,J)),"^",13)="" K OUT D
  1.  ..S X=$P($$ICDDX^ICDCODE(+$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^"),$G(DT),"",1),"^",2) D
  1.  ...S XX=$$ICDD^ICDCODE(X,"OUT"),$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13)=$E($G(OUT(1)),1,79)
  1.  .I $P($G(PXCA("DIAGNOSIS/PROBLEM",I,J)),"^",13)["OTHER#" K OUT D
  1.  ..S X=$P($$ICDDX^ICDCODE(+$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^"),$G(DT),"",1),"^",2) D
  1.  ...S XX=$$ICDD^ICDCODE(X,"OUT"),$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13)=$E($G(OUT(1)),1,79)
  1.  Q
  1.  ;
  1. PRO ; -- make sure diagnosis code is added to DIAGNOSIS/PROBLEM node
  1.  S I=0 F  S I=$O(PXCA("DIAGNOSIS/PROBLEM",I)) Q:I=""  S J=0 F  S J=$O(PXCA("DIAGNOSIS/PROBLEM",I,J)) Q:J=""  D
  1.  .I $TR($P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",5,8),"^","")']"",($P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",2)="") S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",2)="S" D
  1.  ..D LOGERR^IBDF18E2(3579505,.FORMID,"",+PXCA("DIAGNOSIS/PROBLEM",I,J),"","","",$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13))
  1.  .Q:+$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^")
  1.  .I +$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",3) D
  1.  ..S IBX=$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",3) D
  1.  ...I $D(^LEX)>1 S X="LEXU" X ^%ZOSF("TEST") I $T S IBX=$$ICDONE^LEXU(IBX) S:$L(IBX)<1 IBX=799.9 Q  ; clinical lexicon next version to be in ^LEX
  1.  ...S X="GMPTU" X ^%ZOSF("TEST") I $T S IBX=$$ICDONE^GMPTU(IBX) S:$L(IBX)<1 IBX=799.9 Q
  1.  ...S IBX=799.9
  1.  ...Q
  1.  ..S IBXI=+$O(^ICD9("BA",IBX_" ",0)) I +IBXI<1 S IBXI=+$O(^ICD9("BA",799.9_" ",0))
  1.  ..I +IBXI<1 D LOGERR^IBDF18E2(3579506,.FORMID,"",$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",3),"","","",$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13)) Q
  1.  ..S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^")=IBXI
  1.  ..Q
  1.  .;
  1.  .; -- set diagnosis code from problem list into piece 1 of array
  1.  .I +$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",4) S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^")=$$PROBDIA^IBDFBK3(+$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",4))
  1.  Q
  1.  ;
  1. CODES ; -- if addt'l codes to pass and qual is prim or sec, send 2nd code
  1.  N VALUE,IBI,OQLFR
  1.  S OQLFR=QLFR
  1.  Q:$G(QLFR)']""
  1.  Q:"PRIMARYSECONDARYADD TO PROBLEM LIST"'[$P($G(^IBD(357.98,QLFR,0)),"^")
  1.  F IBI=3,4 S VALUE=$P($G(^IBD(357.95,FORMTYPE,1,BUB,2)),"^",IBI) Q:'$G(VALUE)  D
  1.  .N QLFR,TEXT,X,Y
  1.  .D
  1.  ..S X=VALUE
  1.  ..I $G(^ICD9($G(X),0))="" K X S Y="" Q
  1.  ..E  S Y=$$ICDDX^ICDCODE(+X,$G(DT),"",1),Y=$P(Y,"^",4)
  1.  .S TEXT=Y
  1.  .S QLFR=$O(^IBD(357.98,"B",$S($E(OQLFR)="S":"SECONDARY",1:"ADD TO PROBLEM LIST"),0))
  1.  .S ITEM=ITEM_"."_IBI
  1.  .D SETTEMP^IBDF18E1
  1.  .S ITEM=$P(ITEM,".")
  1.  Q
  1.  ;
  1. TRACKING(FORMID) ;get form tracking info,sets FORMID array, which should be pass
  1.  ;
  1.  S NODE=$G(^IBD(357.96,FORMID,0))
  1.  Q:NODE="" 0
  1.  S FORMID("APPT")=$P(NODE,"^",3),FORMID("CLINIC")=$P(NODE,"^",10),FORMID("DFN")=$P(NODE,"^",2),FORMID("SOURCE")=$P(NODE,"^",7)
  1.  Q 1
  1.  ;
  1. SC ; -- if SC answered yes then all other classifications = null
  1.  I $P(PXCA("ENCOUNTER"),"^",6) S $P(PXCA("ENCOUNTER"),"^",7,9)="^^"
  1.  ;
  1.  ; - If 'no classifications' was bubbled in then all other
  1.  ;   classifications = null
  1.  I $P($G(PXCA("IBD NOCLASSIFICATION")),"^",3) S $P(PXCA("ENCOUNTER"),"^",6,10)="^^^^"
  1.  Q
  1.  ;
  1. INPT(DFN,APPT) ; -- determine inpatient status
  1.  N INPT
  1.  S INPT=$P($G(^DPT(+$G(DFN),"S",+$G(APPT),0)),"^",2)="I"
  1.  Q:'INPT
  1.  ;
  1.  ; -- kill erroneous warnings for inpatients
  1.  I $G(PXCA("WARNING","ENCOUNTER",0,0,6))["SC flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,6)
  1.  I $G(PXCA("WARNING","ENCOUNTER",0,0,7))["AO flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,7)
  1.  I $G(PXCA("WARNING","ENCOUNTER",0,0,8))["IR flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,8)
  1.  I $G(PXCA("WARNING","ENCOUNTER",0,0,9))["EC flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,9)
  1.  Q
  1. MODPXCA ; -- copy CPT Modifier information from TEMP to PXCA
  1.  ;
  1.  N MOD,MODX,MODNODE,CODE
  1.  S CODE=$P($G(TEMP(NODE,FID,ITEM)),"^")
  1.  S MOD=0 F  S MOD=$O(TEMP(NODE,FID,ITEM,"MODIFIER",MOD)) Q:MOD']""  D
  1.  . S MODX=TEMP(NODE,FID,ITEM,"MODIFIER",MOD)
  1.  . S MODNODE=$$MODP^ICPTMOD(CODE,MODX)
  1.  . S:+MODNODE>0 PXCA(NODE,PROVIDER,NUMBER,MODX)=$$MOD^ICPTMOD(+MODNODE,"I")
  1.  Q
  1. VSTPXCA ; -- copy CPT Modifier information from TEMP to PXCA for Visit
  1.  ;
  1.  N I,J,MOD,MODX
  1.  S I=0 F  S I=$O(TEMP("ENCOUNTER",I)) Q:I']""  D
  1.  . S J=0 F  S J=$O(TEMP("ENCOUNTER",I,J)) Q:'J  D
  1.  .. S MOD=0 F  S MOD=$O(TEMP("ENCOUNTER",I,J,"MODIFIER",MOD)) Q:MOD']""  D
  1.  ... S MODX=TEMP("ENCOUNTER",I,J,"MODIFIER",MOD)
  1.  ... S PXCA("ENCOUNTER","MODIFIER",MODX)=""
  1.  K TEMP("ENCOUNTER")
  1.  Q