source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBPL.m@ 1806

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PXBPL ;ISL/JVS - ADD DIAGNOSIS TO PROBLEM LIST ; 3/27/02 4:48pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,94,115,130**;Aug 12, 1996
3 ;
4 ;
5 ;
6 W !,"THIS IS NOT AN ENTRY POINT" Q
7SET ;--SETUP AND NEW VARIABLES
8 N OK,PXBPL,FLAG,DATA,ICDCODE
9 D WIN17^PXBCC(PXBCNT)
10 I '$G(NOPLLIST) Q
11PRMPT ;--Ask if you want to put entries in PL
12 S DIR(0)="Y,A,O"
13 S DIR("B")="NO"
14 I PXBCNT'>1 S DIR("A")="Would you like to add this Diagnosis to the Problem List? "
15 I PXBCNT>1 S DIR("A")="Would you like to add any Diagnoses to the Problem List? "
16 D ^DIR K DIR
17 I Y=0!(Y="^")!(Y="") Q
18SELECT ;--Select entries for PL
19 W !
20 I PXBCNT'>1 S OK=1
21 I PXBCNT>1 W !,"Select 1 or several Diagnoses (eg 1,3,4,7,3-6,2-5): " R OK:DTIME
22 I OK?1.N1"E".NAP S OK=" "_OK
23 I OK?24.N S OK=$E(OK,1,24)
24 ;
25 ;
26 I OK["-" D
27 .N PIECE,PXBI,PXBJ,PXBK
28 .S PIECE="" F PXBI=1:1:$L(OK,",") S PIECE=$P(OK,",",PXBI) I PIECE["-" D
29 ..S PXBJ=0 F PXBJ=$P(PIECE,"-",1):1:$P(PIECE,"-",2) S PXBK=","_PXBJ,OK=OK_PXBK
30 ;
31 ;
32 ;
33 S PXBLEN=0
34 I OK["?" W !,"Enter the ITEM numbers of the entries you whish to add to the PROBLEM LIST." G SELECT
35 ;----SPACE BAR---------
36 I OK'=" ",OK'["^",OK'="" S ^DISV(DUZ,"PXBPL-2")=OK
37 I OK=" ",$D(^DISV(DUZ,"PXBPL-2")) S OK=^DISV(DUZ,"PXBPL-2") W OK
38 ;-----------------------
39 S PXBLEN=$L(OK,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(OK,",",PXI) D
40 .Q:PXBPIECE=""
41 .I $D(PXBSAM(PXBPIECE)) D
42 ..S FLAG=1
43 ..D REVPOV^PXBCC(PXBPIECE)
44 I '$G(FLAG) S DIR(0)="Y^AO",DIR("B")="NO",DIR("A")="INVALID entry. Would you like to try again" D ^DIR K DIR I Y=1 K Y G SELECT
45PRV ;--Ask for provider
46 I '$G(FLAG) Q
47 S FROM="PL" D PRV^PXBGPRV(PXBVST)
48R K ERROR S FROM="PL" D PRV^PXBPPRV G:$G(ERROR) R W IOEDEOP
49 I DATA["^P" D LOC^PXBCC(3,0),EN0^PXBDPRV,LOC^PXBCC(15,0) G PRV
50 D POV^PXBGPOV(PXBVST)
51LOOP ;--Loop through diagnosis
52 S PXBLEN=$L(OK,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(OK,",",PXI) D
53 .I PXBPIECE="" Q
54 .I $D(PXBSAM(PXBPIECE)) D
55 ..S PXBPL("PATIENT")=PATIENT
56 ..S PXBPL("NARRATIVE")=$P($G(PXBSAM(PXBPIECE)),"^",3)
57 ..S PXBPL("PROVIDER")=$P(REQI,"^",1)
58 ..S PXBPL("DIAGNOSIS")=+^AUPNVPOV($O(PXBSKY(PXBPIECE,0)),0)
59 ..S PXBPL("LOCATION")=$P(^AUPNVSIT(PXBVST,0),"^",22)
60 ..;PRH - PX*1*115 - Set up Service Conditions
61 ..N PXSCSTR,PXII,PXTYP
62 ..S PXSCSTR="SC^AO^IR^EC^MST^HNC^CV"
63 ..F PXII=1:1:7 D
64 ...S PXTYP=$P(PXSCSTR,"^",PXII)
65 ...S PXBPL(PXTYP)=$P($G(^AUPNVSIT(PXBVST,800)),"^",PXII)
66 ..S ICDCODE="",ICDCODE=$P($G(PXBSAM(PXBPIECE)),"^",1)
67 ..I ICDCODE'="" D ; Get Lexicon entry for ICD Code
68 ...KILL LEXS D EN^LEXCODE(ICDCODE)
69 ...I $G(LEXS("ICD",0))>0 S PXBPL("LEXICON")=$P($G(LEXS("ICD",1)),"^",1)
70 ..D CREATE^GMPLUTL(.PXBPL,.PXBRES)
71 ..D PR
72 K NOPLLIST
73 Q
74SEND ;--Entry point to send data to problem list
75 N PXBPL,OK,ICDCODE
76 I '$D(IORVON) D TERM^PXBCC
77 S PXBPL("PATIENT")=PATIENT
78 S PXBPL("NARRATIVE")=PXBSAM($O(PXBKY($P($P(REQE,"^",5)," ",1),0)),"LNARR")
79 S PXBPL("PROVIDER")=$P(REQI,"^",1)
80 S PXBPL("DIAGNOSIS")=$P(REQI,"^",5)
81 S PXBPL("LOCATION")=$P(^AUPNVSIT(PXBVST,0),"^",22)
82 ;PRH - PX*1*115 - Set up Service Conditions
83 N PXSCSTR,PXII,PXTYP
84 S PXSCSTR="SC^AO^IR^EC^MST^HNC^CV"
85 F PXII=1:1:6 D
86 . S PXTYP=$P(PXSCSTR,"^",PXII)
87 . S PXBPL(PXTYP)=$P($G(^AUPNVSIT(PXBVST,800)),"^",PXII)
88 S ICDCODE="",ICDCODE=$P($G(PXBSAM($O(PXBKY($P($P(REQE,"^",5)," ",1),0)))),"^",1)
89 I ICDCODE'="" D ; Get Lexicon entry for ICD Code
90 .KILL LEXS D EN^LEXCODE(ICDCODE)
91 .I $G(LEXS("ICD",0))>0 S PXBPL("LEXICON")=$P($G(LEXS("ICD",1)),"^",1)
92 D CREATE^GMPLUTL(.PXBPL,.PXBRES)
93PR ;
94 I PXBRES<0 D Q ;'Q'uit added for PX*1*115
95 .W !,IORVON,"--WARNING-Problem NOT Created because: ",PXBRES(0),IORVOFF
96 .D HELP1^PXBUTL1("CON") R OK:DTIME
97 ;
98 ;PX*1*115 - Add Problem File Pointer to V POV file
99 I PXBRES>0 D
100 . N DA,DIE,DR,PXBPLARR,PXBPLERR,PXBPLPOV
101 . S DA=$O(PXBSKY(PXBPIECE,0))
102 . S PXBPLPOV=9000010.07
103 . K PXBPLARR,PXBPLERR
104 . D GETS^DIQ(PXBPLPOV,(DA_","),.16,"I","PXBPLARR","PXBPLERR")
105 . Q:$D(PXBPLERR)
106 . I $L($G(PXBPLARR(PXBPLPOV,(DA_","),.16,"I"))) Q
107 . ;
108 . S DIE="^AUPNVPOV(",DR=".16////"_PXBRES
109 . D ^DIE
110 ;
111 Q
Note: See TracBrowser for help on using the repository browser.