PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04
;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
;
;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.
Q
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%
; must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA
N PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS
S PSODA=RXN,PSO=3,PSODAYS=$$GET1^DIQ(52,PSODA_",","8")
S PSOOLD="Copay"
S PSONW="No Copay"
S PSOSITE=$P(^PSRX(PSODA,2),"^",9)
S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
S PSOFLAG=1 ;1 used here to eliminate display/print of messages.
CSORT ; get orig fill copay info if released.
S RELDAT=$$GET1^DIQ(52,PSODA_",","31","I")
I RELDAT'="" S PSOCSEQ("A",0)=$G(^PSRX(PSODA,"IB"))
;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
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
; get copay info for all released refills; if any
F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 D
. S RELDAT="",RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I")
. Q:RELDAT=""
. S PSOCSEQ("A",PSZ)=$G(^PSRX(PSODA,1,PSZ,"IB"))
; Sort potential refills to be cancelled first starting with last fill
; then orig fill then the rest of the entries.
S (PSZ1,PSZ2,PSZ)="" F S PSZ=$O(PSOCSEQ("A",PSZ),-1) Q:PSZ="" D
. I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
. I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
. I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
. I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
;
;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
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
. F S PSZ=$O(PSOCSEQ("B",PSZ1,PSZ)) Q:PSZ="" D
.. S (PSOREF,PSOIB)="",PSOFLD=PSOFLD+1 S PREA="C" ;$S(PSOFLD=1:"R",1:"C")
.. ;I PSOFLD>1
.. S (PSOOLD,PSONW)=""
.. S PSOREF=PSZ
.. ;
.. S PSOPFS="",PSOPFS=$P($S('PSOREF:$G(^PSRX(PSODA,"PFS")),1:$G(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2)
.. 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
.. ;
.. N TYPE S PSOIB=PSOCSEQ("A",PSOREF),TYPE=PSOREF
.. 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
.. I PSOSCP<50 D RXED^PSOCPA ;IB - if SC<50 and not billed via PFSS
SET S:$D(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$G(PSOSI)) $P(^PSRX(RXN,"IB"),"^",1)=""
K PSOSCP
Q
;
OBR ;Flag/Unflag orders
I PSOTYPE'="OBR"!($G(PSOSEG)="") Q
N PSOFLAG,PSORDER,PSOPEN,DR,PSOREA,PSOBY,PSONOW
S PSORDER=+$P($P(PSOSEG,"|",2),"^") ; Pointer to ORDER file (#100)
S PSOPEN=+$O(^PS(52.41,"B",PSORDER,0)) ; Pointer to PENDING OUTPATIENT ORDERS file (#52.41)
S PSOFLAG=$P(PSOSEG,"|",4) ; "FL" for Flag and "UF" for Unflag action
S PSOREA=$P(PSOSEG,"|",13) ; Reason for Flag/Unflag (Freetext up to 80chars)
S PSOBY=$P(PSOSEG,"|",16) ; Flagged/Unflagged By - Pointer to NEW PERSON file (#200)
S PSONOW=$E($$NOW^XLFDT(),1,12) ; CURRENT DATE/TIME wihtout seconds
;
I 'PSOPEN!'$P($G(^PS(52.41,PSOPEN,0)),"^") D EN^ORERR("Invalid Pending Order/Flag Msg",.MSG) Q
;
I PSOFLAG="FL" D
. S $P(^PS(52.41,PSOPEN,"FLG"),"^",1,3)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80)
. S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)="^^"
. S $P(^PS(52.41,PSOPEN,0),"^",23)=1
E D
. S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80)
. S $P(^PS(52.41,PSOPEN,0),"^",23)=""
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLNE4 4382 printed Oct 16, 2024@18:30:37 Page 2
PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04
+1 ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
+2 ;
+3 ;This API is used to update the prescription file when ICD-9 diagnosis
+4 ; and SC/EI's are updated as a result of an e-sig in CPRS.
+5 QUIT
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%
+1 ; must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA
+2 NEW PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS
+3 SET PSODA=RXN
SET PSO=3
SET PSODAYS=$$GET1^DIQ(52,PSODA_",","8")
+4 SET PSOOLD="Copay"
+5 SET PSONW="No Copay"
+6 SET PSOSITE=$PIECE(^PSRX(PSODA,2),"^",9)
+7 SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
+8 ;1 used here to eliminate display/print of messages.
SET PSOFLAG=1
CSORT ; get orig fill copay info if released.
+1 SET RELDAT=$$GET1^DIQ(52,PSODA_",","31","I")
+2 IF RELDAT'=""
SET PSOCSEQ("A",0)=$GET(^PSRX(PSODA,"IB"))
+3 ;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
+4 ;set act log when unreleased, but SC/EI changed copay
IF RELDAT=""
SET PREA="R"
if +$GET(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1))
DO ACTLOG^PSOCPA
GOTO SET
+5 ; get copay info for all released refills; if any
+6 FOR PSZ=0:0
SET PSZ=$ORDER(^PSRX(PSODA,1,PSZ))
if PSZ'>0
QUIT
Begin DoDot:1
+7 SET RELDAT=""
SET RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I")
+8 if RELDAT=""
QUIT
+9 SET PSOCSEQ("A",PSZ)=$GET(^PSRX(PSODA,1,PSZ,"IB"))
End DoDot:1
+10 ; Sort potential refills to be cancelled first starting with last fill
+11 ; then orig fill then the rest of the entries.
+12 SET (PSZ1,PSZ2,PSZ)=""
FOR
SET PSZ=$ORDER(PSOCSEQ("A",PSZ),-1)
if PSZ=""
QUIT
Begin DoDot:1
+13 IF PSZ>0&($PIECE(PSOCSEQ("A",PSZ),"^",2)'="")
SET PSZ1=PSZ1+1
SET PSOCSEQ("B",PSZ1,PSZ)=""
QUIT
+14 IF PSZ>0&($PIECE(PSOCSEQ("A",PSZ),"^",2)="")
SET PSZ2=PSZ2+1000
SET PSOCSEQ("B",PSZ2,PSZ)=""
QUIT
+15 IF PSZ=0&($PIECE(PSOCSEQ("A",PSZ),"^",4)'="")
SET PSZ1=PSZ1+1
SET PSOCSEQ("B",PSZ1,PSZ)=""
QUIT
+16 IF PSZ=0&($PIECE(PSOCSEQ("A",PSZ),"^",4)="")
SET PSZ2=PSZ2+1000
SET PSOCSEQ("B",PSZ2,PSZ)=""
QUIT
End DoDot:1
+17 ;
+18 ;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
+19 SET (PSZ,PSZ1)=""
SET PSOFLD=0
SET PREA="R"
if +$GET(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1))
DO ACTLOG^PSOCPA
FOR
SET PSZ1=$ORDER(PSOCSEQ("B",PSZ1))
if PSZ1=""
QUIT
Begin DoDot:1
+20 FOR
SET PSZ=$ORDER(PSOCSEQ("B",PSZ1,PSZ))
if PSZ=""
QUIT
Begin DoDot:2
+21 ;$S(PSOFLD=1:"R",1:"C")
SET (PSOREF,PSOIB)=""
SET PSOFLD=PSOFLD+1
SET PREA="C"
+22 ;I PSOFLD>1
+23 SET (PSOOLD,PSONW)=""
+24 SET PSOREF=PSZ
+25 ;
+26 SET PSOPFS=""
SET PSOPFS=$PIECE($SELECT('PSOREF:$GET(^PSRX(PSODA,"PFS")),1:$GET(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2)
+27 ;don't send unreleased charge msg
IF +$GET(PSOPFS)>0&('$PIECE($GET(PSOPFS),"^",2))
KILL PSOPFS
QUIT
+28 ;invalid PFSS ACCT REF/ SEND TO IB
IF +$GET(PSOPFS)<1
KILL PSOPFS
+29 IF +$GET(PSOPFS)>0
SET PSOPFS="1^"_PSOPFS
+30 ;
+31 NEW TYPE
SET PSOIB=PSOCSEQ("A",PSOREF)
SET TYPE=PSOREF
+32 ;PFSS charge update only
IF +$GET(PSOPFS)
DO CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS)
if +$GET(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1))
DO ACTLOG^PSOCPA
QUIT
+33 ;IB - if SC<50 and not billed via PFSS
IF PSOSCP<50
DO RXED^PSOCPA
End DoDot:2
End DoDot:1
SET if $DATA(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$GET(PSOSI))
SET $PIECE(^PSRX(RXN,"IB"),"^",1)=""
+1 KILL PSOSCP
+2 QUIT
+3 ;
OBR ;Flag/Unflag orders
+1 IF PSOTYPE'="OBR"!($GET(PSOSEG)="")
QUIT
+2 NEW PSOFLAG,PSORDER,PSOPEN,DR,PSOREA,PSOBY,PSONOW
+3 ; Pointer to ORDER file (#100)
SET PSORDER=+$PIECE($PIECE(PSOSEG,"|",2),"^")
+4 ; Pointer to PENDING OUTPATIENT ORDERS file (#52.41)
SET PSOPEN=+$ORDER(^PS(52.41,"B",PSORDER,0))
+5 ; "FL" for Flag and "UF" for Unflag action
SET PSOFLAG=$PIECE(PSOSEG,"|",4)
+6 ; Reason for Flag/Unflag (Freetext up to 80chars)
SET PSOREA=$PIECE(PSOSEG,"|",13)
+7 ; Flagged/Unflagged By - Pointer to NEW PERSON file (#200)
SET PSOBY=$PIECE(PSOSEG,"|",16)
+8 ; CURRENT DATE/TIME wihtout seconds
SET PSONOW=$EXTRACT($$NOW^XLFDT(),1,12)
+9 ;
+10 IF 'PSOPEN!'$PIECE($GET(^PS(52.41,PSOPEN,0)),"^")
DO EN^ORERR("Invalid Pending Order/Flag Msg",.MSG)
QUIT
+11 ;
+12 IF PSOFLAG="FL"
Begin DoDot:1
+13 SET $PIECE(^PS(52.41,PSOPEN,"FLG"),"^",1,3)=PSONOW_"^"_PSOBY_"^"_$EXTRACT(PSOREA,1,80)
+14 SET $PIECE(^PS(52.41,PSOPEN,"FLG"),"^",4,6)="^^"
+15 SET $PIECE(^PS(52.41,PSOPEN,0),"^",23)=1
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET $PIECE(^PS(52.41,PSOPEN,"FLG"),"^",4,6)=PSONOW_"^"_PSOBY_"^"_$EXTRACT(PSOREA,1,80)
+18 SET $PIECE(^PS(52.41,PSOPEN,0),"^",23)=""
End DoDot:1
+19 ;
+20 QUIT
