- 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 Mar 13, 2025@21:34:51 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
