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

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

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ;4/6/05 2:41pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,121,124**;Aug 12, 1996
3 ;
4 ;
5 ;
6 ;
7 ;
8ADDM ;--------If Multiple POV entries have been entered.
9 ;
10 ;
11 ;
12 N OK,PXBLEN,BDATA
13 D WIN17^PXBCC(PXBCNT)
14 S NF=0,PXBLEN=0
15 I DATA[",",$E(DATA,1)'["@" S NF=1 D
16 .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
17 ..S X=PXBPIECE,DIC=80,DIC(0)="IMZ",DIC("S")="I $P($$ICDDX^ICDCODE(Y,IDATE),U,10)" D ^DIC
18 ..I Y=-1 S BAD(+$G(PXBPIECE))="" Q
19 ..S $P(REQI,"^",5)=+Y
20 ..S PXBNPOV(PXBPIECE)=""
21 ..;
22 ..;--Prompt for Primary or Secondary DIAGNOSIS
23 ..W !,"For the DIAGNOSIS: ",PXBPIECE,"--"
24 ..W $P($$ICDDX^ICDCODE(PXBPIECE,IDATE),U,2),!
25 ..D WIN17^PXBCC(PXBCNT)
26 ..D PRI^PXBPPOV1
27 ..I $D(DIRUT) D RSET^PXBDREQ("POV") Q
28 ..D ORD^PXBPPOV1
29 ..N PXCEVIEN,PXCEAFTR,PXD
30 ..S PXCEVIEN=PXBVST,PXD=$P(REQI,U,5)
31 ..D WIN17^PXBCC(PXBCNT),GET800^PXCEC800 ;CI's
32 ..S PXBREQ(PXD,"I")=$G(PXCEAFTR(800))
33 ..;
34 ..D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
35 ..D EN1^PXKMAIN
36 ..D RSET^PXBDREQ("POV")
37 I $G(NF)&($D(BAD)) D Q
38 .S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
39 .W ! D HELP^PXBUTL0("CPTM") W !
40 .S DIR(0)="E" D ^DIR K DIR,DIRUT
41 .S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
42 I $G(NF)&('$D(BAD)) S DATA="^P" Q
43 ;
44 Q
45 ;
46DELM ;--------If Multiple deleting
47 N DELM,PXBJ,BAD,PXBLEN,BDATA
48 S NF=0,PXBLEN=0 S $P(DELM,"^",3)=1
49 I $E(DATA,1)="@" S DATA=$P(DATA,"@",2),NF=1 D
50 .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
51 ..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
52 ..I PXBPIECE'["-" D
53 ...I $D(GONE(PXBPIECE)) Q
54 ...Q:PXBPIECE'?.N
55 ...S $P(REQI,"^",9)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
56 ...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC=80,DIC(0)="IZM",DIC("S")="I $P($$ICDDX^ICDCODE(Y,IDATE),U,10)" D ^DIC
57 ...S $P(REQI,"^",5)=+Y K Y
58 ...S GONE(PXBPIECE)=""
59 ...D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
60 ...D EN1^PXKMAIN
61 ..I PXBPIECE["-" D
62 ...F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
63 ....I $D(GONE(PXBJ)) Q
64 ....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
65 ....S $P(REQI,"^",9)=$O(PXBSKY(PXBJ,0)) ;-IEN
66 ....S X=$P(PXBSAM(PXBJ),"^",1),DIC=80,DIC(0)="IZM",DIC("S")="I $P($$ICDDX^ICDCODE(Y,IDATE),U,10)" D ^DIC
67 ....S $P(REQI,"^",5)=+Y K Y
68 ....S GONE(PXBJ)=""
69 ....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
70 ....D EN1^PXKMAIN
71 K GONE
72 I $G(NF)&($D(BAD)) D Q
73 .S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
74 .W ! D HELP^PXBUTL0("CPTMD") W !
75 .S DIR(0)="E" D ^DIR K DIR
76 .S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
77 I $G(NF)&('$D(BAD)) S DATA="^P" Q
78 Q
79PRI ;--Prompt for primary secondary DIAGNOSIS
80 N DIR,Y,X,SEQ
81 S SEQ=0 I $D(PXBKY(DATA)) S SEQ=+$O(PXBKY(DATA,"")) ;PX112
82 I $G(FPRI),$P($G(PXBKY(DATA,SEQ)),U,4)'="PRIMARY" Q ;PX112
83 W IOCUD,IOELALL,IOCUU
84 S DIR("A",1)="ONE primary diagnosis must be established for each encounter!"
85 S DIR("A")="Is this the PRIMARY DIAGNOSIS for this ENCOUNTER? "
86 S DIR("B")="YES"
87 S DIR("?")="One PRIMARY DIAGNOSIS must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
88 S DIR(0)="Y,A,O"
89 D ^DIR I $G(DIRUT) G PPXIT
90PPFIN ;--Finish off variables
91 I Y=1 S PRI="P^PRIMARY"
92 I Y=0 S PRI="S^SECONDARY"
93 S $P(REQI,"^",6)=$P(PRI,"^",1)
94 S $P(REQE,"^",6)=$P(PRI,"^",2)
95PPXIT ;--EXIT
96 Q
97ORD ;--Prompt for ordering resulting DIAGNOSIS
98 N DIR,Y,X,SEQ
99 S SEQ=0 I $D(PXBKY(DATA)) S SEQ=+$O(PXBKY(DATA,""))
100 W IOCUD,IOELALL,IOCUU
101 S DIR("A")="Is this Diagnosis Ordering or Resulting:"
102 S DIR("B")=$P($G(PXBKY(DATA,SEQ)),U,7)
103 S DIR("?")="Resulting and/or Ordering indicators are only entered if at least one of each diagnosis type exists."
104 S DIR(0)="SO^O:ORDERING;R:RESULTING;OR:BOTH O&R"
105 D ^DIR I $G(DIRUT) G PPXIT
106ORFIN ;--Finish off variables
107 S $P(REQI,"^",7)=Y
108 S $P(REQE,"^",7)=$S(Y="O":"ORDERING",Y="R":"RESULTING",1:"BOTH O&R")
109 Q
110PRBLM ;--Prompt for Problem list
111 N DIR,Y,X,VALL
112 W IOCUD,IOELALL,IOCUU
113 D WIN17^PXBCC(PXBCNT)
114 S DIR("?")="^S VALL=1,VALL=$$DOUBLE1^PXBGPL2(WHAT)"
115 S DIR("A")="Do you want this DIAGNOSIS added to the PROBLEM LIST? "
116 S DIR("B")="NO"
117 S DIR(0)="Y,A,O"
118 D ^DIR
119 I X="+"!(X="-") S DIR("?")="D DPOV4^PXBDPL(X)"
120 I $G(DIRUT) G PPXIT
121PRPFIN ;--Finish off variables
122 K PXBKYPL,PXBSKYPL,PXBSAMPL,PXBCNTPL
123 K ^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J)
124 S PXBPRBLM=+Y
125PRPXIT ;--EXIT
126 Q
127 ;
Note: See TracBrowser for help on using the repository browser.