source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF18E0.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1IBDF18E0 ;ALB/CJM - ENCOUNTER FORM - PCE DEVICE INTERFACE utilities ;04-OCT-94
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**11,25,38,36,23**;APR 24, 1997
3 ;
4SETPXCA ;set values from TEMP() into the PXCA()
5 ;
6 N NODE,NUMBER,IBQUIT,Y,Y1,X
7 S PROVIDER=+$P(PXCA("ENCOUNTER"),"^",4)
8 I PROVIDER,"^P^S^"'[("^"_$P(PXCA("ENCOUNTER"),"^",15)_"^") S $P(PXCA("ENCOUNTER"),"^",15)="S" D LOGERR^IBDF18E2(3579603,.FORMID,"",PROVIDER)
9 ;
10 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
11 .S IBQUIT=0
12 .I NODE="PROCEDURE" S X=TEMP(NODE,FID,ITEM) D
13 ..I $P(X,"^",2)="" S $P(X,"^",2)=1
14 ..S Y=0 F S Y=$O(PXCA(NODE,PROVIDER,Y)) Q:'Y!(IBQUIT) D
15 ...S Y1=$G(PXCA(NODE,PROVIDER,Y))
16 ...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
17 ..Q:IBQUIT
18 ..S TEMP(NODE,FID,ITEM)=X
19 .I IBQUIT K TEMP(NODE,FID,ITEM) Q
20 .S NUMBER=NUMBER+1
21 .S PXCA(NODE,PROVIDER,NUMBER)=TEMP(NODE,FID,ITEM)
22 .I $D(TEMP(NODE,FID,ITEM,"MODIFIER")) D MODPXCA
23 .K TEMP(NODE,FID,ITEM)
24 ;
25 ; -- default c/o date time to now if not passed
26 I '$P($G(^IBD(357.09,1,1)),"^",2) D ;cont only if s/p not answerred
27 .I $D(PXCA("ENCOUNTER")) I $P(PXCA("ENCOUNTER"),"^",14)="" D ;quit if we are already passing c/o date/time
28 ..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)))
29 ..Q:$$COMDT^SDCOU(+SDOE) ;c/o already performed, don't overwrite
30 ..N IBDDFN,IBDAPPT,IBDCLN,IBDCOST
31 ..S IBDDFN=$S(+$G(FORMID("DFN")):+$G(FORMID("DFN")),+$G(IBDF("DFN")):+$G(IBDF("DFN")),1:$G(DFN))
32 ..S IBDAPPT=$S(+$G(FORMID("APPT")):+$G(FORMID("APPT")),+$G(IBDF("APPT")):+$G(IBDF("APPT")),1:$G(APPT))
33 ..S IBDCLN=$S(+$G(FORMID("CLINIC")):+$G(FORMID("CLINIC")),+$G(IBDF("CLINIC")):+$G(IBDF("CLINIC")),1:$G(CLN))
34 ..S IBDCOST=$$STATUS^SDAM1(IBDDFN,IBDAPPT,IBDCLN,$G(^DPT(IBDDFN,0))) Q:$P(IBDCOST,";",5)
35 ..S $P(PXCA("ENCOUNTER"),"^",14)=$E($$HTFM^XLFDT($H),1,12)
36 ;
37 D OTHRBUB
38 Q
39 ;
40 ;
41OTHRBUB ; -- check procedure and diagnosis node for other bubble, but no data
42 N NODE,CODE
43 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
44 .I +$G(PXCA("PROCEDURE",I,J))<1 D ;no code, may be treatment
45 ..I $P($G(PXCA("PROCEDURE",I,J)),"^",6)["OTHER#" D ;no code, narr=other
46 ...D LOGERR^IBDF18E2(3579612,.FORMID)
47 ...K PXCA("PROCEDURE",I,J)
48 .I +$G(PXCA("PROCEDURE",I,J)),$P($G(PXCA("PROCEDURE",I,J)),"^",6)["OTHER#" D
49 ..;; --change to api cpt ; dhh
50 ..S CODE=$$CPT^ICPTCOD(CODE)
51 ..S $P(PXCA("PROCEDURE",I,J),"^",6)=$S(+CODE'=-1:$E($P((CODE),"^",3),1,80),1:"")
52 ;
53 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
54 .I $P($G(PXCA("DIAGNOSIS/PROBLEM",I,J)),"^",13)="" D
55 ..S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13)=$E($G(^ICD9(+PXCA("DIAGNOSIS/PROBLEM",I,J),1)),1,79)
56 .I $P($G(PXCA("DIAGNOSIS/PROBLEM",I,J)),"^",13)["OTHER#" D
57 ..S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13)=$E($G(^ICD9(+PXCA("DIAGNOSIS/PROBLEM",I,J),1)),1,79)
58 Q
59 ;
60PRO ; -- make sure diagnosis code is added to DIAGNOSIS/PROBLEM node
61 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
62 .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
63 ..D LOGERR^IBDF18E2(3579505,.FORMID,"",+PXCA("DIAGNOSIS/PROBLEM",I,J),"","","",$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13))
64 .Q:+$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^")
65 .I +$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",3) D
66 ..S IBX=$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",3) D
67 ...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
68 ...S X="GMPTU" X ^%ZOSF("TEST") I $T S IBX=$$ICDONE^GMPTU(IBX) S:$L(IBX)<1 IBX=799.9 Q
69 ...S IBX=799.9
70 ...Q
71 ..S IBXI=+$O(^ICD9("BA",IBX_" ",0)) I +IBXI<1 S IBXI=+$O(^ICD9("BA",799.9_" ",0))
72 ..I +IBXI<1 D LOGERR^IBDF18E2(3579506,.FORMID,"",$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",3),"","","",$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",13)) Q
73 ..S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^")=IBXI
74 ..Q
75 .;
76 .; -- set diagnosis code from problem list into piece 1 of array
77 .I +$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",4) S $P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^")=$$PROBDIA^IBDFBK3(+$P(PXCA("DIAGNOSIS/PROBLEM",I,J),"^",4))
78 Q
79 ;
80CODES ; -- if addt'l codes to pass and qual is prim or sec, send 2nd code
81 N VALUE,IBI,OQLFR
82 S OQLFR=QLFR
83 Q:$G(QLFR)']""
84 Q:"PRIMARYSECONDARYADD TO PROBLEM LIST"'[$P($G(^IBD(357.98,QLFR,0)),"^")
85 F IBI=3,4 S VALUE=$P($G(^IBD(357.95,FORMTYPE,1,BUB,2)),"^",IBI) Q:'$G(VALUE) D
86 .N QLFR,TEXT,X,Y
87 .D
88 ..S X=VALUE
89 ..I $G(^ICD9($G(X),0))="" K X S Y="" Q
90 ..E S Y=$P(^ICD9(X,0),"^",3)
91 .S TEXT=Y
92 .S QLFR=$O(^IBD(357.98,"B",$S($E(OQLFR)="S":"SECONDARY",1:"ADD TO PROBLEM LIST"),0))
93 .S ITEM=ITEM_"."_IBI
94 .D SETTEMP^IBDF18E1
95 .S ITEM=$P(ITEM,".")
96 Q
97 ;
98TRACKING(FORMID) ;get form tracking info,sets FORMID array, which should be passed by reference, return 0 if not found
99 ;
100 S NODE=$G(^IBD(357.96,FORMID,0))
101 Q:NODE="" 0
102 S FORMID("APPT")=$P(NODE,"^",3),FORMID("CLINIC")=$P(NODE,"^",10),FORMID("DFN")=$P(NODE,"^",2),FORMID("SOURCE")=$P(NODE,"^",7)
103 Q 1
104 ;
105SC ; -- if SC answered yes then all other classifications = null
106 I $P(PXCA("ENCOUNTER"),"^",6) S $P(PXCA("ENCOUNTER"),"^",7,9)="^^"
107 ;
108 ; - If 'no classifications' was bubbled in then all other
109 ; classifications = null
110 I $P($G(PXCA("IBD NOCLASSIFICATION")),"^",3) S $P(PXCA("ENCOUNTER"),"^",6,10)="^^^^"
111 Q
112 ;
113INPT(DFN,APPT) ; -- determine inpatient status
114 N INPT
115 S INPT=$P($G(^DPT(+$G(DFN),"S",+$G(APPT),0)),"^",2)="I"
116 Q:'INPT
117 ;
118 ; -- kill erroneous warnings for inpatients
119 I $G(PXCA("WARNING","ENCOUNTER",0,0,6))["SC flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,6)
120 I $G(PXCA("WARNING","ENCOUNTER",0,0,7))["AO flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,7)
121 I $G(PXCA("WARNING","ENCOUNTER",0,0,8))["IR flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,8)
122 I $G(PXCA("WARNING","ENCOUNTER",0,0,9))["EC flag is missing" K PXCA("WARNING","ENCOUNTER",0,0,9)
123 Q
124MODPXCA ; -- copy CPT Modifier information from TEMP to PXCA
125 ;
126 N MOD,MODX,MODNODE,CODE
127 S CODE=$P($G(TEMP(NODE,FID,ITEM)),"^")
128 S MOD=0 F S MOD=$O(TEMP(NODE,FID,ITEM,"MODIFIER",MOD)) Q:MOD']"" D
129 . S MODX=TEMP(NODE,FID,ITEM,"MODIFIER",MOD)
130 . S MODNODE=$$MODP^ICPTMOD(CODE,MODX)
131 . S:+MODNODE>0 PXCA(NODE,PROVIDER,NUMBER,MODX)=$$MOD^ICPTMOD(+MODNODE,"I")
132 Q
133VSTPXCA ; -- copy CPT Modifier information from TEMP to PXCA for Visit
134 ;
135 N I,J,MOD,MODX
136 S I=0 F S I=$O(TEMP("ENCOUNTER",I)) Q:I']"" D
137 . S J=0 F S J=$O(TEMP("ENCOUNTER",I,J)) Q:'J D
138 .. S MOD=0 F S MOD=$O(TEMP("ENCOUNTER",I,J,"MODIFIER",MOD)) Q:MOD']"" D
139 ... S MODX=TEMP("ENCOUNTER",I,J,"MODIFIER",MOD)
140 ... S PXCA("ENCOUNTER","MODIFIER",MODX)=""
141 K TEMP("ENCOUNTER")
142 Q
Note: See TracBrowser for help on using the repository browser.