- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE4.m
r613 r623 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 1 PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04 2 ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997 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 ;
Note:
See TracChangeset
for help on using the changeset viewer.
