1 | PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04
|
---|
2 | ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
|
---|
3 | ;
|
---|
4 | ;This API is used to update the prescription file when ICD-9 diagnosis
|
---|
5 | ; and SC/EI's are updated as a result of an e-sig in CPRS.
|
---|
6 | Q
|
---|
7 | COPAY ;For IB, cancel copay charges if SC<50% and SC/EI changed and released; For PFS, send charge update msgs for SC 0-100%
|
---|
8 | ; must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA
|
---|
9 | N PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS
|
---|
10 | S PSODA=RXN,PSO=3,PSODAYS=$$GET1^DIQ(52,PSODA_",","8")
|
---|
11 | S PSOOLD="Copay"
|
---|
12 | S PSONW="No Copay"
|
---|
13 | S PSOSITE=$P(^PSRX(PSODA,2),"^",9)
|
---|
14 | S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
|
---|
15 | S PSOFLAG=1 ;1 used here to eliminate display/print of messages.
|
---|
16 | CSORT ; get orig fill copay info if released.
|
---|
17 | S RELDAT=$$GET1^DIQ(52,PSODA_",","31","I")
|
---|
18 | I RELDAT'="" S PSOCSEQ("A",0)=$G(^PSRX(PSODA,"IB"))
|
---|
19 | ;I RELDAT="" S PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay
|
---|
20 | I RELDAT="" S PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay
|
---|
21 | ; get copay info for all released refills; if any
|
---|
22 | F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 D
|
---|
23 | . S RELDAT="",RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I")
|
---|
24 | . Q:RELDAT=""
|
---|
25 | . S PSOCSEQ("A",PSZ)=$G(^PSRX(PSODA,1,PSZ,"IB"))
|
---|
26 | ; Sort potential refills to be cancelled first starting with last fill
|
---|
27 | ; then orig fill then the rest of the entries.
|
---|
28 | S (PSZ1,PSZ2,PSZ)="" F S PSZ=$O(PSOCSEQ("A",PSZ),-1) Q:PSZ="" D
|
---|
29 | . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
|
---|
30 | . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
|
---|
31 | . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
|
---|
32 | . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
|
---|
33 | ;
|
---|
34 | ;S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA F S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1="" D
|
---|
35 | S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA F S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1="" D
|
---|
36 | . F S PSZ=$O(PSOCSEQ("B",PSZ1,PSZ)) Q:PSZ="" D
|
---|
37 | .. S (PSOREF,PSOIB)="",PSOFLD=PSOFLD+1 S PREA="C" ;$S(PSOFLD=1:"R",1:"C")
|
---|
38 | .. ;I PSOFLD>1
|
---|
39 | .. S (PSOOLD,PSONW)=""
|
---|
40 | .. S PSOREF=PSZ
|
---|
41 | .. ;
|
---|
42 | .. S PSOPFS="",PSOPFS=$P($S('PSOREF:$G(^PSRX(PSODA,"PFS")),1:$G(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2)
|
---|
43 | .. I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg
|
---|
44 | .. I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB
|
---|
45 | .. I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
|
---|
46 | .. ;
|
---|
47 | .. N TYPE S PSOIB=PSOCSEQ("A",PSOREF),TYPE=PSOREF
|
---|
48 | .. I +$G(PSOPFS) D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA Q ;PFSS charge update only
|
---|
49 | .. I PSOSCP<50 D RXED^PSOCPA ;IB - if SC<50 and not billed via PFSS
|
---|
50 | SET S:$D(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$G(PSOSI)) $P(^PSRX(RXN,"IB"),"^",1)=""
|
---|
51 | K PSOSCP
|
---|
52 | Q
|
---|
53 | ;
|
---|
54 | OBR ;Flag/Unflag orders
|
---|
55 | I PSOTYPE'="OBR"!($G(PSOSEG)="") Q
|
---|
56 | N PSOFLAG,PSORDER,PSOPEN,DR,PSOREA,PSOBY,PSONOW
|
---|
57 | S PSORDER=+$P($P(PSOSEG,"|",2),"^") ; Pointer to ORDER file (#100)
|
---|
58 | S PSOPEN=+$O(^PS(52.41,"B",PSORDER,0)) ; Pointer to PENDING OUTPATIENT ORDERS file (#52.41)
|
---|
59 | S PSOFLAG=$P(PSOSEG,"|",4) ; "FL" for Flag and "UF" for Unflag action
|
---|
60 | S PSOREA=$P(PSOSEG,"|",13) ; Reason for Flag/Unflag (Freetext up to 80chars)
|
---|
61 | S PSOBY=$P(PSOSEG,"|",16) ; Flagged/Unflagged By - Pointer to NEW PERSON file (#200)
|
---|
62 | S PSONOW=$E($$NOW^XLFDT(),1,12) ; CURRENT DATE/TIME wihtout seconds
|
---|
63 | ;
|
---|
64 | I 'PSOPEN!'$P($G(^PS(52.41,PSOPEN,0)),"^") D EN^ORERR("Invalid Pending Order/Flag Msg",.MSG) Q
|
---|
65 | ;
|
---|
66 | I PSOFLAG="FL" D
|
---|
67 | . S $P(^PS(52.41,PSOPEN,"FLG"),"^",1,3)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80)
|
---|
68 | . S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)="^^"
|
---|
69 | . S $P(^PS(52.41,PSOPEN,0),"^",23)=1
|
---|
70 | E D
|
---|
71 | . S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80)
|
---|
72 | . S $P(^PS(52.41,PSOPEN,0),"^",23)=""
|
---|
73 | ;
|
---|
74 | Q
|
---|