162 lines
9.1 KiB
Mathematica
162 lines
9.1 KiB
Mathematica
|
PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04
|
||
|
|
;;7.0;OUTPATIENT PHARMACY;**143,239,201,225**;DEC 1997;Build 29
|
||
|
|
;External reference to ^OR(100 private DBIA 2219
|
||
|
|
;External reference VADPT supported by DBIA 10061
|
||
|
|
;
|
||
|
|
;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS.
|
||
|
|
;
|
||
|
|
EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT
|
||
|
|
; Used to import edit information from CPRS
|
||
|
|
;Where Input:
|
||
|
|
;DFN = Patient IEN
|
||
|
|
;ORITEM = Package reference number from file 100
|
||
|
|
;ORIEN = ien from file 100
|
||
|
|
;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD
|
||
|
|
;ORDX(2)= (pointer to file 80)
|
||
|
|
;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked
|
||
|
|
; ORSCEI=AO^IR^SC^EC^MST^HNC^CV^SHAD
|
||
|
|
N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW
|
||
|
|
N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA
|
||
|
|
N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD
|
||
|
|
S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM=""
|
||
|
|
;
|
||
|
|
;validate prescription IEN with DFN, ord item, and placer#
|
||
|
|
S RET=1,PSODCZ=",12,14,15,"
|
||
|
|
S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET ;invalid RX ien
|
||
|
|
I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA")
|
||
|
|
; get prescription file patient ien, drug, and placer order #
|
||
|
|
D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY")
|
||
|
|
I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET ;quit if you don't have a patient ien
|
||
|
|
I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET ;quit if patient dfn is different
|
||
|
|
I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")="" ;if don't have it; treat is as null
|
||
|
|
I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET ;placer # is different
|
||
|
|
I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET ;quit if placer # is null and orderable item is different or null.
|
||
|
|
;end of validation process
|
||
|
|
;
|
||
|
|
S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1
|
||
|
|
S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
|
||
|
|
S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN
|
||
|
|
S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I")
|
||
|
|
I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)=""
|
||
|
|
;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF. If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay.
|
||
|
|
I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","")
|
||
|
|
D SCP^PSORN52D
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1)
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2)
|
||
|
|
I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3)
|
||
|
|
I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3)
|
||
|
|
I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC") ;for SC with no percentage defined/ legacy
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4)
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5)
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6)
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7)
|
||
|
|
S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(ORSCEI,U,8)
|
||
|
|
D:'$$PATCH^XPDUTL("OR*3.0*243") SHAD^PSORN52D
|
||
|
|
S DX="",DX2=0 F S DX=$O(ORDX(DX)) Q:DX="" S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX) ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx
|
||
|
|
S PSOSCP2=1 ;used in PSORN52D
|
||
|
|
;
|
||
|
|
ICD2 ;Check to see if SC/EI changed during CPRS sign order
|
||
|
|
D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD")
|
||
|
|
S PSODCPY=0,PSOFLD=""
|
||
|
|
F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV","SHAD" Q:PSODCPY F PSOFLD=1:1:8 D Q:PSODCPY
|
||
|
|
. I TYPE="VEH"&(PSOFLD=1) D CHOC
|
||
|
|
. I TYPE="RAD"&(PSOFLD=2) D CHOC
|
||
|
|
. I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC
|
||
|
|
. I TYPE="PGW"&(PSOFLD=4) D CHOC
|
||
|
|
. I TYPE="MST"&(PSOFLD=5) D CHOC
|
||
|
|
. I TYPE="HNC"&(PSOFLD=6) D CHOC
|
||
|
|
. I TYPE="CV"&(PSOFLD=7) D CHOC
|
||
|
|
. I TYPE="SHAD"&(PSOFLD=8) D:$$PATCH^XPDUTL("OR*3.0*243") CHOC
|
||
|
|
I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD=""
|
||
|
|
; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES. If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done.
|
||
|
|
I '$G(PSODCPY) D
|
||
|
|
.I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP
|
||
|
|
.S (DX3,DX2,DX)="" F S DX=$O(PSOOICD(52.052311,DX)) Q:DX="" S DX2=+DX ;get last entry for file 52
|
||
|
|
.S DX="" F S DX=$O(PSORX("ICD",DX)) Q:DX="" S DX3=DX D ;get last entry for new ICD's from CPRS
|
||
|
|
.. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1 ;if ICD'S changed or more new ICD's than old ones.
|
||
|
|
.I DX2>DX3 S PSODGUP=1 ;if more old ICD's than new ones
|
||
|
|
Q:'$G(PSODCPY)&('$G(PSODGUP)) 1
|
||
|
|
D FILE2^PSORN52D ;file SC/EI/ICD'S into Rx file
|
||
|
|
;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
|
||
|
|
;only do copay if SC/EI changed and SC is less than 50%.
|
||
|
|
I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET ;discontinue's no copay changes allowed.
|
||
|
|
;
|
||
|
|
;Get last fill number
|
||
|
|
N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN)
|
||
|
|
S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2)
|
||
|
|
; No-copay to copay updates
|
||
|
|
S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
|
||
|
|
D CPAY
|
||
|
|
; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's
|
||
|
|
I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D Q RET ;don't do no copay to copay bills, but update status
|
||
|
|
. D ALOG
|
||
|
|
. I (PSOSCP<50)&($G(PSODCPY)) D
|
||
|
|
.. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D
|
||
|
|
... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)=""
|
||
|
|
... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA
|
||
|
|
. I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg
|
||
|
|
. I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB
|
||
|
|
. I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
|
||
|
|
. ;
|
||
|
|
. I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys
|
||
|
|
;
|
||
|
|
; Copay to no-copay updates
|
||
|
|
I $G(PSODCPY) D COPAY^PSOHLNE4
|
||
|
|
;ICD UPDATE ONLY FOR COPAYS
|
||
|
|
I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY
|
||
|
|
I ($G(PSODCPY)!($G(PSODGUP))) D ALOG
|
||
|
|
Q RET
|
||
|
|
;
|
||
|
|
CPAY ;
|
||
|
|
N X,Y,III,ACTYP,BL
|
||
|
|
S PSOSITE=$P(^PSRX(RXN,2),"^",9)
|
||
|
|
S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX
|
||
|
|
S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0
|
||
|
|
CPAY1 ;
|
||
|
|
S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL)
|
||
|
|
G CPAY1
|
||
|
|
CSKP ;
|
||
|
|
S:$G(PSOSI) PSOCPAY=0 ;Supply item/investigational drug
|
||
|
|
S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0 ;Rx Patient Status exempt
|
||
|
|
I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1 ;Yes SC/EI from CPRS
|
||
|
|
I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0 ;INELIGIBLE
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CHOC ;check outpatient classifications
|
||
|
|
S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
ALOG ;set activity log with edit info from cprs
|
||
|
|
N ACNT,SUB,RF,RFCNT
|
||
|
|
S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB S ACNT=SUB
|
||
|
|
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
|
||
|
|
D NOW^%DTC S ACNT=ACNT+1
|
||
|
|
S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"."
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CHKOI ;get and compare orderable items in file #100 and #52; don't process
|
||
|
|
; if it's different and the placer # is null.
|
||
|
|
I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q
|
||
|
|
D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI")
|
||
|
|
S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I")
|
||
|
|
S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1)
|
||
|
|
I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1
|
||
|
|
Q
|
||
|
|
TEST(ORIEN) ;manually test an individual order record
|
||
|
|
N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ
|
||
|
|
S (JJ,I)=0 F S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN) S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0))
|
||
|
|
S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1)
|
||
|
|
S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I)
|
||
|
|
S:$$PATCH^XPDUTL("OR*3.0*243") ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",8)
|
||
|
|
S ORSCEI=$E(ORSCEI,2,99)
|
||
|
|
S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1)
|
||
|
|
D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI)
|
||
|
|
Q
|
||
|
|
OBXNTE ; Called from PSOHLNEW due to it's routine size.
|
||
|
|
S LL=ZZ+1,PSOBCT=2
|
||
|
|
I $P($G(MSG(LL)),"|")="NTE" D
|
||
|
|
.I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4)
|
||
|
|
.F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D
|
||
|
|
..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1
|
||
|
|
Q
|