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

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

initial load of WorldVistAEHR

File size: 4.5 KB
RevLine 
[613]1PXBPPOV ;ISL/JVS - PROMPT POV ;8/31/05
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28,92,121,149,124,170,182**;Aug 12, 1996;Build 3
3 ;
4 ; VARIABLE LIST
5 ; SELINE= Line number of selected item
6 ;
7POV ;--DIAGNOSIS
8 I $D(PXBNPOVL) D LOC^PXBCC(2,0) W IOUON,"Previous Entry: ",$G(PXBNPOVL(1)) F I=1:1:10 W " "
9 W IOUOFF
10 N TIMED,EDATA,DIC,LINE,XFLAG,SELINE,PXBEDIS,FPL,CNT
11 I '$D(^DISV(DUZ,"PXBPOV-3")) S ^DISV(DUZ,"PXBPOV-3")=" "
12 I '$D(IOSC) D TERM^PXBCC
13 S DOUBLEQQ=0
14 S TIMED="I '$T!(DATA=""^"")"
15 S DIC("S")="I $P($$ICDDX^ICDCODE(Y,IDATE),U,10)"
16P ;--Second Entry point
17 W IOSC K FPL,EDATA,DATA
18 ;---DYNAMIC HEADER---
19 I '$D(CYCL) D
20 .S CNT=$G(PXBCNT)\2
21 .I CNT=0,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There are "_CNT_" ICD CODES associated with this encounter."
22 .I CNT=1,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There is "_CNT_" ICD CODE associated with this encounter."
23 .I CNT>1,DOUBLEQQ=0 D LOC^PXBCC(1,10) W "...There are "_CNT_" ICD CODES associated with this encounter."
24 D LOC^PXBCC(15,0)
25 I PXBCNT>10&('$G(DOUBLEQQ)) W !,"Enter '+' for next page, '-' for previous page."
26 I '$D(^TMP("PXK",$J,"POV")) W !,"Enter Diagnosis : "_$G(PXBDPOV) W:$D(PXBDPOV) " //" W IOELEOL
27 I $D(^TMP("PXK",$J,"POV")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," Diagnosis : "_$G(PXBDPOV) W:$D(PXBDPOV) " //" W IOELEOL
28 R DATA:DTIME S EDATA=DATA
29P1 ;--Third entry point
30 X TIMED I S PXBUT=1,LEAVE=1,DATA="^" G POVX
31 I DATA?1.N1"E".NAP S DATA=" "_DATA
32 I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
33 I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
34 D CASE^PXBUTL
35 ;----SPACE BAR---
36 I DATA=" ",$D(^DISV(DUZ,"PXBPOV-3")) S DATA=^DISV(DUZ,"PXBPOV-3") W DATA
37 ;-----------------
38 I DATA="^^" S PXBEXIT=0 G POVX
39 ;---I Prompt can jump to others put symbols in here
40 I DATA["^P" G POVX
41 ;------PXBDPOV=DEFAULT POV---PX*1.0*182 - added variable EDATA
42 I DATA="",$D(PXBDPOV) S DATA=$P($G(PXBDPOV),"--",1),EDATA=DATA
43 I DATA="",'$D(PXBDPOV) S PXBUT=1,PXBSPL="",LEAVE=1 G POVX
44 I PXBCNT>10&((DATA="+")!(DATA="-")) D DPOV4^PXBDPOV(DATA) G P
45 ;
46M ;--------IF Multiple entries have been entered
47 D ADDM^PXBPPOV1
48 I $G(NF) G P1
49 ;
50 ;--------IF Multiple deleting of entries
51 D DELM^PXBPPOV1
52 I $G(NF) G P1
53 ;
54LI ;--------If picked a line number
55 I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) S XFLAG=1 D REVPOV^PXBCC(DATA) S SELINE=DATA D
56 .F I=1:1:$L(DATA) W IOCUB,IOECH
57 .S PRISEC=$P($G(PXBSAM(DATA)),"^",4) S:PRISEC["PRI" FPRI=0
58 .S DATA=$P($G(PXBSAM(DATA)),"^",1)
59 I $D(XFLAG),XFLAG=1 S (Y,EDATA)=DATA G PFIN
60LI1 ;
61 ;--------If POV is already in the file
62 I '$G(DOUBLEQQ),$D(PXBKY(DATA)) D
63 .I PXBCNT>10 D DPOV4^PXBDPOV($O(PXBKY(DATA,0)))
64 .K Q D TIMES^PXBUTL(DATA)
65 .I Q=1 S LINE=$O(PXBKY(DATA,0)) S XFLAG=1 D REVPOV^PXBCC(LINE) S PRISEC=$P($G(PXBSAM(LINE)),"^",2) S:PRISEC["PRI" FPRI=0
66 .I Q>1 S NLINE=0 F S NLINE=$O(Q(NLINE)) Q:NLINE="" D REVPOV^PXBCC(NLINE)
67 I $D(Q),Q>1 D WHICH^PXBPWCH G LI
68 I $D(XFLAG),XFLAG=1 S Y=DATA G PFIN
69 ;
70 ;--------Need to do a DIC lookup on data
71 I DATA'="??" D:DATA="?" EN1^PXBHLP0("PXB","POV",1,"",1) G:DATA="^P" P1 I DATA="?" G P
72 I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","POV","",1,2) S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P($P(DATA,"^",2),"--",1) G:Y>1 PFIN G:Y?1A1.NP PFIN I DATA<1 S DATA="^P" G P1
73 ;
74 ;--If a "?" is NOT entered during lookup
75 K X,DIC
76 S X=EDATA
77 D CONFIG^LEXSET("ICD",,IDATE)
78 S DIC("A")="Select Diagnosis:"
79 S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM"
80 D ^DIC
81 I X="@" Q
82 I Y=-1 S DATA="^P" G P1
83 S WHAT=$G(Y(1))
84 S X="`"_+$$CODEN^ICDCODE(WHAT,80)
85 S (DATA,EDATA)=WHAT K Y
86 S DIC=80,DIC(0)="MZ",DIC("S")="I $P($$ICDDX^ICDCODE(Y,IDATE),U,10)" D ^DIC
87 ;
88 ;--If Y is good and already in file...
89 I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D
90 .S LINE=$O(PXBKY($P(Y,"^",2),0)) ;---D REVPOV^PXBCC(LINE)
91 .S PRISEC=$P($G(PXBSAM(LINE)),"^",4) S:PRISEC["PRI" FPRI=0
92 S POV=Y(0)
93 ;
94PFIN ;--Finish the DIAGNOSIS
95 I $L(Y,"^")'>1 S X=Y,DIC=80,DIC(0)="IZM",DIC("S")="I $P($$ICDDX^ICDCODE(Y,IDATE),U,10)" D ^DIC
96 I +Y<0 D HELP1^PXBUTL1("POV") G P
97 S POV=Y(0)
98 ;get the correct diagnosis descriptor
99 N DXINF S DXINF=$$ICDDX^ICDCODE(+Y,IDATE),$P(POV,U,3)=$P(DXINF,U,4)
100 S PXBNPOV($P(POV,"^",1))=""
101 S PXBNPOVL(1)=$P(POV,"^",1) S ^DISV(DUZ,"PXBPOV-3")=DATA
102 I $D(PXBKY($P(Y(0),"^"))),$G(SELINE) S $P(REQI,"^",9)=$O(PXBSKY(SELINE,0))
103 I $D(PXBKY($P(Y(0),"^"))),'$G(SELINE) S $P(REQI,"^",9)=$O(PXBSKY($O(PXBKY($P(Y(0),"^"),0)),0))
104 I +Y>0 S PXBEDIS=$P(DXINF,U,4)
105 S $P(REQI,"^",5)=+Y,$P(REQI,"^",6)="S"
106 S $P(REQE,"^",5)=$P(POV,"^",1)_" --"_$G(PXBEDIS),$P(REQE,"^",6)="SECONDARY"
107POVX ;--EXIT AND CLEAN UP
108 I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
109 I '$D(REQE) S REQE=""
110 I $P(REQE,"^",5)="" S $P(REQE,"^",5)="...No Diagnosis Selected..."
111 Q
Note: See TracBrowser for help on using the repository browser.