source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m@ 1336

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

initial load of FOIAVistA 6/30/08 version

File size: 7.9 KB
Line 
1ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;07/05/04
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215**;Dec 17, 1997
3 ;
4 ; DBIA 2950 LOOK^LEXA ^TMP("LEXFND",$J)
5 ; DBIA 1609 CONFIG^LEXSET ^TMP("LEXSCH",$J)
6 ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J)
7 ; DBIA 3991 $$STATCHK^ICDAPIU
8 ;
9 Q
10VISIT(LST,CLINIC,ORDATE) ; get list of visit types for clinic
11 S:'+$G(ORDATE) ORDATE=DT
12 D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE)
13 Q
14PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods
15 S:'+$G(ORDATE) ORDATE=DT
16 D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE)
17 N IDX,MOD,CODES,FIRST S IDX=0
18 F S IDX=$O(LST(IDX)) Q:'+IDX D
19 . I LST(IDX)="" K LST(IDX) Q
20 . S MOD=0,CODES="",FIRST=1
21 . F S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="") D
22 . . I FIRST S FIRST=0
23 . . E S CODES=CODES_";"
24 . . S CODES=CODES_LST(IDX,"MODIFIER",MOD)
25 . K LST(IDX,"MODIFIER")
26 . I 'FIRST S $P(LST(IDX),U,12)=CODES
27 Q
28CPTMODS(LST,ORCPTCOD,ORDATE) ;Return CPT Modifiers for a CPT Code
29 N ORM,ORIDX,ORI,MODNAME
30 S:'+$G(ORDATE) ORDATE=DT
31 I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D
32 . S ORIDX="",ORI=0
33 . F S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="") D
34 . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1)
35 . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX
36 Q
37GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier
38 N ORDATA
39 S:'+$G(ORDATE) ORDATE=DT
40 S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1)
41 I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2)
42 Q
43DIAG(LST,CLINIC,ORDATE) ; get list of diagnoses for clinic
44 S:'+$G(ORDATE) ORDATE=DT
45 D GETLST^IBDF18A(CLINIC,"DG SELECT ICD-9 DIAGNOSIS CODES","LST",,,,ORDATE)
46 Q
47IMM(LST,CLINIC) ;get list of immunizations for clinic
48 D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST")
49 Q
50SK(LST,CLINIC) ;get list of skin test for clinic
51 D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST")
52 Q
53HF(LST,CLINIC) ;get list of health factors for clinic
54 D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST")
55 Q
56PED(LST,CLINIC) ;get list of education topices for clinic
57 D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST")
58 Q
59TRT(LST,CLINIC) ;get list of treatments for clinic
60 D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST")
61 Q
62XAM(LST,CLINIC) ;get list of exams for clinic
63 D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST")
64 Q
65ACTPROB(GLST,DFN,ORDATE) ;get list of patient's active problems
66 K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
67 S:'+$G(ORDATE) ORDATE=DT
68 D DSELECT^GMPLENFM ;DBIA 1365
69 N ORPROB,ORPROBIX,ORPRCNT
70 S ORPRCNT=0
71 S ORPROBIX=0
72 F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365
73 . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)
74 . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255)
75 . I '$D(ORPROB(ORPROB)) D
76 .. S ORPROB(ORPROB)=""
77 .. S ORPRCNT=ORPRCNT+1
78 .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB
79 . E K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)
80 ; DBIA 10082 NAME: ICD DIAGNOSIS FILE
81 N ORWINDEX,ORITEM
82 S ORWINDEX=0
83 F S ORWINDEX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)) Q:'ORWINDEX D:$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX),"^",1)]""
84 . S ORITEM=^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)
85 . I '+$$STATCHK^ICDAPIU($P(ORITEM,"^",3),ORDATE) S $P(ORITEM,"^",11)="#" ;DBIA 3991
86 . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)=ORITEM
87 S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT
88 S GLST="^TMP(""IB"","_$J_",""INTERFACES"",""GMP SELECT PATIENT ACTIVE PROBLEMS"")"
89 Q
90SCSEL(VAL,DFN,ATM,LOC,VST) ; return SC conditions that may be selected
91 ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt;
92 ; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt
93 N ORX,S S S=";"
94 D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX)
95 S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV"))
96 Q
97SCDIS(LST,DFN) ; Return service connected % and rated disabilities
98 N VAEL,VAERR,I,ILST,DIS,SC,X
99 D ELIG^VADPT
100 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
101 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
102 S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D
103 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
104 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
105 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
106 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
107 Q
108CPTREQD(VAL,IEN) ; return 1 in VAL if note still needs a CPT code
109 S VAL=+$P(^TIU(8925,IEN,0),U,11)
110 Q
111NOTEVSTR(VAL,IEN) ; return the VSTR^AUTHOR for a note
112 N X0,X12,VISIT
113 S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7)
114 I +VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT) I 1
115 E S VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13)
116 Q
117HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) ;Has visit or is stand alone
118 N ORVISIT
119 S ORY=-1
120 I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3)
121 I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC)
122 I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT)
123 Q
124DELETE(VAL,VSTR,DFN) ; delete PCE info when deleting a note
125 N VISIT,ORCOUNT
126 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
127 I '$D(^TMP("ORWPCE",$J,VSTR)) S VAL=0 Q ; no PCE data saved yet
128 I $P(VSTR,";",3)="H" S VAL=0 Q ; leave inpatient alone
129 I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q ; leave if no tiu entry point
130 D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR) ; Do not delete if another
131 I ORCOUNT>0 S VAL=0 Q ; title points to visit
132 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H
133 S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE"
134 S ZTSYNC="ORW"_VSTR
135 D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1
136 Q
137SAVE(OK,PCELIST,NOTEIEN,ORLOC) ; save PCE information
138 N VSTR,GMPLUSER
139 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
140 S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR)
141 M ^TMP("ORWPCE",$J,VSTR)=PCELIST
142 S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN)
143 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H
144 S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE"
145 S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")=""
146 I VSTR'["E" S ZTSYNC="ORW"_VSTR
147 S ZTSAVE("ORLOC")=""
148 D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1
149 Q
150LEX(LST,X,APP,ORDATE) ; return list after lexicon lookup
151 N LEX,ILST,I,IEN
152 S:APP="CPT" APP="CHP" ; LEX PATCH 10
153 S:'+$G(ORDATE) ORDATE=DT
154 D CONFIG^LEXSET(APP,APP,ORDATE) ;DBIA 1609
155 I APP="CHP" D
156 . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")
157 . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))" ;DBIA 1609
158 . ; Set Applications Default Flag (Lexicon can not overwrite filter)
159 . S ^TMP("LEXSCH",$J,"ADF",0)=1
160 D LOOK^LEXA(X,APP,1,"",ORDATE)
161 I '$D(LEX("LIST",1)) S LST(1)="-1^No matches found." Q
162 S LST(1)=LEX("LIST",1),ILST=1
163 S (I,IEN)=""
164 F S I=$O(^TMP("LEXFND",$J,I)) Q:I="" D ;DBIA 2950
165 .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN="" D
166 ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN)
167 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
168 Q
169LEXCODE(VAL,IEN,APP,ORDATE) ; return code for a lexicon entry
170 S VAL=""
171 S:'+$G(ORDATE) ORDATE=DT
172 I APP="ICD" S VAL=$$ICDONE^LEXU(IEN,ORDATE)
173 I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE) ; LEX PATCH 10
174 I VAL="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE) ; LEX PATCH 10
175 Q
176ADDRES ; Add the ORW/PXAPI RESOURCE device
177 N X
178 S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions")
179 Q
180GETSVC(NEWSVC,SVC,LOC,INP) ; Returns the correct Service Connected Category
181 N DSS,ORWSVC
182 S DSS=$P($G(^SC(+LOC,0)),U,7)
183 Q:'+DSS
184 M ORWSVC=SVC
185 S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225
186 Q
Note: See TracBrowser for help on using the repository browser.