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