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

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

initial load of WorldVistAEHR

File size: 7.4 KB
RevLine 
[613]1PXBPPRV ;ISL/JVS,ESW - PROMPT PROVIDER ; 7/12/07 11:14am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,7,11,19,108,141,152,186**;Aug 12, 1996;Build 3
3 ;
4 ; VARIABLE LIST
5 ; SELINE= Line number of selected item
6 ;
7PRV ;--PROVIDER
8 I $D(PXBUT),$G(PXBUT) S PXBUT=0 ; patch *186*
9 I $D(PXBNPRVL) W IOSC D LOC^PXBCC(2,0) W IOUON,"Previous Entry: ",$G(PXBNPRVL(1)) F I=1:1:10 W " "
10 I $D(PXBNPRVL) W IORC
11 W IOUOFF
12 N TIMED,EDATA,DIC,LINE,XFLAG,SELINE,UDATA,ECHO
13 I '$D(^DISV(DUZ,"PXBPRV-4")) S ^DISV(DUZ,"PXBPRV-4")=" "
14 I '$D(IOSC) D TERM^PXBCC
15 S DOUBLEQQ=0
16 S TIMED="I '$T!(DATA=""^"")"
17P ;--Second Entry point
18 W IOSC
19 ;--DYNAMIC HEADER--
20 I '$D(CYCL) D
21 .I PXBCNT=0,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" PROVIDER(S) associated with this encounter."
22 .I PXBCNT=1,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There is "_$G(PXBCNT)_" PROVIDER associated with this encounter."
23 .I PXBCNT>1,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" PROVIDERS associated with this encounter."
24 ;
25 I $G(FROM)'="PL" D LOC^PXBCC(15,0)
26 I $G(FROM)'["PRV" N PXBNPRVL
27 I $D(FROM),FROM="PL" W IORC
28 I $G(FROM)'="PL",PXBCNT>10&('$G(DOUBLEQQ)) W IOELEOL,!,"Enter '+' for next page, '-' for previous page."
29 ;--Dynamic prompting for the provider--
30 I '$D(^TMP("PXK",$J,"PRV")),'$D(FROM) W !,"Enter PROVIDER: " W IOELEOL
31 I '$D(FROM),$D(^TMP("PXK",$J,"PRV")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROVIDER: " W IOELEOL
32 I $D(FROM),FROM="CPT",'$D(^TMP("PXK",$J,"PRV")) W IORC,!,"Enter PROVIDER associated with PROCEDURE: " W IOELEOL
33 I $D(FROM),FROM="PRV" W !,"Enter PROVIDER: " W IOELEOL
34 I $D(FROM),FROM="CPT",$D(^TMP("PXK",$J,"PRV")) W IORC,!,"Enter PROVIDER associated with PROCEDURES: " W IOELEOL
35 I $D(FROM),FROM="PL" W !,"Enter PROVIDER associated with PROBLEM: " W IOELEOL
36 I $D(FROM),FROM="PL" S PXBDPRV="^"_$P($G(PRVDR("PRIMARY")),U) ;;108
37 ;I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U) S:$G(PXBCNT)>1&($P($G(REQE),U)=0) D0=$P($G(PRVDR("PRIMARY")),U,3)
38 I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U),D0=$P($G(PRVDR("PRIMARY")),U,3)
39 I $D(FROM),FROM="CPT",$P(REQI,U,1),$P(REQE,U,1)'["..." S $P(PXBDPRV,U,2)=$P(REQE,U,1)
40 I $P($G(REQI),U,8)'="",$G(FROM)'="CPT" S D0=$P($G(^AUPNVCPT($P(REQI,U,8),12)),U,4),PXBDPRV="^"_$P(REQE,U)
41 ; begin patch *186*
42 ; W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV) " // ",IOELEOL
43 W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV)&($G(PXBDPRV)'="^") " // ",IOELEOL
44 ; end patch *186*
45 ;
46 R DATA:DTIME S (EDATA,ECHO)=DATA
47P1 ;--Third entry point
48 X TIMED I S PXBUT=1 S:DATA="^" LEAVE=1 G PRVX
49 I DATA?1.N1"E".NAP S DATA=" "_DATA
50 I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
51 I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
52 D CASE^PXBUTL
53 ;---SPACE BAR
54 I DATA=" ",$D(^DISV(DUZ,"PXBPRV-4")) S (DATA,EDATA)=^DISV(DUZ,"PXBPRV-4") W DATA
55 ;-----------
56 I DATA="^^" S PXBEXIT=0 G PRVX
57 ;---I Prompt can jump to others put symbols in here
58 I DATA["^P" G PRVX
59 I DATA["^I" G PRVX
60 ; PX*1.0*152 - need to flag if default has been chosen. PXBDPRV gets killed so can't be used as flag.
61 N PXDEF152 S PXDEF152=0
62 I DATA="",$D(PXBDPRV) S DATA=$P($G(PXBDPRV),"^",2),PXDEF152=1 I DATA="" S PXBUT=1 G PRVX
63 I DATA="",'$D(PXBDPRV) S PXBUT=1 G PRVX
64 ;
65 I PXBCNT>10&((DATA="+")!(DATA="-")) D DPRV4^PXBDPRV(DATA) W IORC D WIN17^PXBCC(PXBCNT) G P
66 ;
67 K PRVN1 S VIEN=0 F I=1:1 S VIEN=$O(PXBSAM(VIEN)) Q:VIEN="" S PRVN1=PXBSAM(VIEN),PRVN1($P(PRVN1,U,4))=PRVN1_"^"_VIEN
68M ;--IF Multiple entries have been entered
69 ;--CAN'T DO!!!!
70 ;--IF Multiple deleting of entries
71 D DELM^PXBPPRV1
72 I $G(NF) G P1
73 ;
74LI ;--If picked a line number
75 I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) S XFLAG=1 D REVPRV^PXBCC(DATA) S SELINE=DATA D
76 .I $G(FROM)["PL" Q
77 .I $G(FROM)["CPT" K SELINE S DATA="NOT VALID" Q
78 .F I=1:1:$L(DATA) W IOCUB,IOECH
79 .S PRISEC=$P($G(PXBSAM(DATA)),U,2) S:PRISEC["PRI" FPRI=0
80 .S DATA=$P($G(PXBSAM(DATA)),U,1)
81 I $D(XFLAG),XFLAG=1 S Y=DATA G PFIN
82 ;
83 ;--If PRV is already in the file
84 I DATA="" S PXBUT=1 G PRVX
85 I $G(FROM)'="CPT",'$G(DOUBLEQQ),$D(PXBKY(DATA)) D
86 .I PXBCNT>10 D DPRV4^PXBDPRV($O(PXBKY(DATA,0)))
87 .K Q D TIMES^PXBUTL(DATA)
88 .I Q=1 S LINE=$O(PXBKY(DATA,0)) S XFLAG=1 D:$G(FROM)'="PL" REVPRV^PXBCC(LINE) S PRISEC=$P($G(PXBSAM(LINE)),"^",2) I $P(PXBSAM(LINE),"^",2)["PRI" S FPRI=0
89 .I Q>1 S NLINE=0 F S NLINE=$O(Q(NLINE)) Q:NLINE="" D REVPRV^PXBCC(NLINE)
90 I $D(Q),Q>1 D WHICH^PXBPWCH G LI
91 I $D(XFLAG),XFLAG=1 S Y=DATA S:"CPT:PRV"[FROM&($G(D0)>0) Y="`"_D0 G PFIN
92 ;--Need to do a DIC lookup on data
93 ;
94 K FIRST
95 I DATA'="??" D:DATA="?" EN1^PXBHLP0("PXB","PRV",1,"",1) G:DATA="^P" P I DATA="?" G P
96 I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","PRV","",1,2) S:DATA="P" UDATA="^P" S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P(DATA,U,2) S:$G(UDATA)="" UDATA="^P" S:UDATA="^P" (DATA,EDATA,Y)=UDATA G:UDATA="^P" P1 G PFIN
97 ;
98 ;--If a "?" is NOT entered during lookup
99 ;----PX*1.0*152
100 ;----If PXDEF152 is 1 then the user has hit the enter key with a specific provider provided as the default.
101 ;----There should be no need to prompt again.
102 I PXDEF152 D
103 .S X=DATA,DIC="^VA(200,",DIC(0)="O"
104 .D ^DIC S VAL=Y
105 .I Y<1 S PXDEF152=0
106 ; begin patch *186*
107 ; I 'PXDEF152 S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
108 I 'PXDEF152 N PXOFROM S PXOFROM=FROM D S FROM=PXOFROM ;save FROM
109 . S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM)
110 . I Y<1,$G(ERROR)=1,$G(CYCL)=1 D
111 . . D HELP1^PXBUTL1("CON") R X:DTIME
112 . . I PXOFROM'="CPT" D LOC^PXBCC(3,1) W IOEDEOP D EN0^PXBDPRV K CYCL
113 . . I PXOFROM="CPT" D LOC^PXBCC(4,1) W IOEDEOP N Y D HEADER^PXBMCPT2
114 ; end patch *186*
115 I Y<1 S DATA="^P",DOUBLEQQ=1 G P1
116 ;S (X,DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
117 ; begin patch *186*
118 ; S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
119 ; I Y=-1 S PXBUT=1 G PRVX
120 S DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
121 S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
122 I Y=-1 D G PRVX
123 . D LOC^PXBCC(16,0),HELP^PXBUTL0("PRVM")
124 . D HELP1^PXBUTL1("CON") R X:DTIME
125 . D LOC^PXBCC(3,1) W IOEDEOP
126 . D LOC^PXBCC(15,0)
127 . S DATA="^P",PXBUT=1,FIRST=1
128 . D:FROM="CPT" HEADER^PXBMCPT2
129 ; end patch *186*
130 ;--If Y is good and already in file...
131 ;I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D
132 I '$G(DOUBLEQQ),($P($G(Y),U)>0),$D(PRVN1($P(Y,U))) D
133 .S LINE=$P(PRVN1($P(Y,U)),U,5)
134 .S PRISEC=$P($G(PXBSAM(LINE)),"^",2) S:PRISEC["PRI" FPRI=0
135 S PRV=Y(0)
136 ;
137PFIN ;--Finish the Provider
138 I $L(Y,"^")'>1,$G(SELINE) S X="`"_$P(^AUPNVPRV($O(PXBSKY(SELINE,0)),0),"^",1),DIC="^VA(200,",DIC(0)="MZ" D ^DIC
139 I $L(Y,"^")'>1,'$G(SELINE) S X=Y,DIC="^VA(200,",DIC(0)="MZ" D ^DIC
140 I +Y<0 D HELP^PXBUTL0("PRVM") W IOCUU G P
141 S PRV=Y(0)
142 S PXBNPRV($P(PRV,U,1))=""
143 S PXBNPRVL(1)=$P(PRV,U,1) S ^DISV(DUZ,"PXBPRV-4")=$P(PRV,U,1)
144 I $D(PRVN1($P(Y,U))),$G(SELINE) S $P(REQI,U,7)=$O(PXBSKY(SELINE,0)),$P(REQI,U,2)=$P($G(PXBSAM(SELINE)),U,2)
145 I $D(PRVN1($P(Y,U))),'$G(SELINE) S PRVN1=PRVN1($P(Y,U)) D
146 .S $P(REQI,U,7)=$O(PXBSKY($P(PRVN1,U,5),0))
147 .S PAT=$P(Y(0),U,1),ITEM=$P(PRVN1,U,5),$P(REQI,U,2)=$E($P(PRVN1,U,2),1),$P(REQE,U,2)=$P(PRVN1,U,2)
148 S $P(REQI,U,1)=+Y
149 I $P(REQI,U,2)']"" S $P(REQI,U,2)="S",$P(REQE,U,2)="SECONDARY"
150 S $P(REQE,U,1)=$P(PRV,U,1)
151 I '$D(REQI) S REQI=""
152 ;---IF INACTIVE ISSUE A WARNING
153 I DATA]"" D ACTIVE^PXBPPRV1 K DIR
154PRVX ;--EXIT AND CLEAN UP
155 K PRVN1,VIEN,D0
156 I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
157 I '$D(REQI) S REQI=""
158 I '$D(REQE) S REQE=""
159 I $P(REQE,U,1)="" S $P(REQE,U,1)="...No Provider Selected..."
160 ; begin patch *186*
161 ; I FROM="PRV",$L(EDATA)<40 D
162 I "CPT:PL:PRV"[FROM,$L(EDATA)<40 D
163 .F I=1:1:$L(ECHO) W IOCUB,IOELEOL
164 .F I=1:1:$L(ECHO) W IOCUF
165 .I $P(REQE,U,1)'["...No" W $P(REQE,U,1)
166 Q
Note: See TracBrowser for help on using the repository browser.