Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCIDC2.m

    r613 r623  
    1 PSOCIDC2        ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm
    2         ;;7.0;OUTPATIENT PHARMACY;**226,225**;DEC 1997;Build 29
    3         ;External reference to ^XUSEC supported by DBIA 10076
    4         ;External reference to IBARX supported by DBIA 125
    5         ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
    6         ;
    7 TOTAL   ;
    8         N COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED
    9         I '$D(PSOVETS) S PSOVETS=0
    10         N I,J
    11         F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0
    12         S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT REL",PSODFN)) Q:'PSODFN  D
    13         .S COUNTED=0
    14         .F J="YR2004","YR2005","YR2006" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
    15         F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I))
    16         ;
    17         S (I,J)=-""
    18         I '$D(PSOCVETS) S PSOCVETS=0
    19         F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0
    20         S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN  D
    21         .S CCOUNTED=0
    22         .F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT
    23         F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I))
    24         ;
    25         S (I,J)=""
    26         I '$D(PSOUVETS) S PSOUVETS=0
    27         F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0
    28         S PSOUDFN=0 F  S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN  D
    29         .S UCOUNTED=0
    30         .F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT
    31         F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I))
    32         ;
    33         Q
    34         ;
    35 CHECK   ;check for ICD and IB nodes
    36         ;
    37         N PSOREF,PSOIB,PSOOICD,PSOBILLD
    38         S PSOREF=YY
    39         S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8)
    40         ; see if bill already exists
    41         I PSOREF=0 D
    42         . I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
    43         . S PSOREL=$P($G(^PSRX(RXP,2)),"^",13)
    44         I PSOREF>0 D
    45         . I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
    46         . S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
    47         I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
    48         ;    if billed/RELEASED and no IBQ node for both sc<50 and nsc
    49         I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
    50         . I $TR(PSOOICD,"^")[1  S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
    51         . I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
    52         ;           find unbilled ones with an ICD node and no IBQ node.
    53         I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
    54         . Q:$TR(PSOOICD,"^")=""
    55         . S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
    56         I YY S PSOTRF=PSOTRF+1
    57         Q
    58         ;
    59 CANCEL  ;Cancel erroneous copays/set IBQ node if not there
    60         ;released rx's
    61         N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE
    62         N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB
    63         N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL
    64         S PSOTYPE="CAN"
    65         S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN  D  Q:STOP
    66         .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
    67         .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
    68         .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
    69         .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP  D
    70         ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
    71         ..S YY="" F  S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY=""  D
    72         ...S (SAVREF,PSOREF)=YY
    73         ...;  verify again that it was billed and not already cancelled
    74         ...S PSOBILLD=0
    75         ...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
    76         ...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
    77         ...Q:'PSOBILLD
    78         ...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3)
    79         ...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA=""
    80         ...D CHKACT
    81         ...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"")
    82         ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
    83         ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
    84         ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ
    85         ...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
    86         ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
    87         ...D ACCUM
    88         ;
    89         ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased.
    90         S PSOTYP="IBQ"
    91         S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN  D  Q:STOP
    92         .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
    93         .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
    94         .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
    95         .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP  D
    96         ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
    97         ..S YY="" F  S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY=""  D
    98         ...S (SAVREF,PSOREF)=YY
    99         ...D SITE
    100         ...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3)
    101         ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
    102         ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
    103         ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D   ;don't want to set again if already did it as part of copay cancel
    104         ....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I  S IFN=I
    105         ....S COM=" BKGD CIDC UPDATE"
    106         ....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM
    107         ....K DA
    108         ....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
    109         ...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM
    110         ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
    111         Q
    112         ;
    113 CHKACT  ;check activity log for prev entry
    114         N ZACT,ZPSI,ZACTI
    115         S ZPSI=0 F  S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI=""  S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D  Q:$G(ZACT)
    116         . I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q
    117         I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C"
    118         Q
    119         ;
    120 SETIBQ  ; get data from IBQ node, set IBQ node, and 1st piece of IB node
    121         K PSOANSQ
    122         N PSONIBQ
    123         F PSOTYP=1:1:8 D
    124         . I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP)
    125         . I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP)
    126         . I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP)
    127         . I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP)
    128         . I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP)
    129         . I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP)
    130         . I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP)
    131         . I PSOTYP=8 S PSOANSQ("SHAD")=$P(PSOOICD,"^",PSOTYP)
    132         S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")_"^"_PSOANSQ("SHAD")
    133         Q
    134         ;
    135 ACCUM   ; ACCUMULATE TOTALS
    136         S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)=""
    137         ; get finished, but unreleased totals
    138         I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR=""  D  S PSOYEAR="" Q
    139         .S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR=""
    140         .S PSOCHRG=7
    141         .I PSOYEAR="YR2006" S PSOCHRG=8
    142         .S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR))
    143         .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
    144         .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1
    145         .S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
    146         .S PSONAM=$E(PSONAM,1,6)
    147         .S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD
    148         ;for released ones
    149         S PSOYR=$E(PSOREL,1,3)
    150         S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
    151         Q:PSOYEAR=""
    152         S PSOCHRG=7
    153         I PSOYEAR="YR2006" S PSOCHRG=8
    154         ;
    155         ;get Xtmp billing amt which would be IBAM tot + any previous refills
    156         S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR))
    157         ;
    158         ;if none yet then init to the IBAM total for the year
    159         I 'PSOTOT D
    160         .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ  D
    161         ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
    162         ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
    163         ;
    164         ;update Xtmp tot nodes with current fill amounts
    165         ;  note:  cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3
    166         ;             routine.  Cancelled copays are denoted with an asterisk.
    167         S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
    168         S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1
    169         ;
    170         ;indicate COPAY CANCEL for this fill
    171         ;       ;by adding to Xtmp "BILLED"
    172         S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
    173         S PSONAM=$E(PSONAM,1,6)
    174         S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
    175         ;
    176 CAN     I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D
    177         . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
    178         . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1
    179         Q
    180         ;
    181 SITE    ; SET UP VARIABLES NEEDED BY BILLING
    182         S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
    183         Q:PSOSITE=""
    184         S PSOPAR=$G(^PS(59,PSOSITE,1))
    185         S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
    186         S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
    187         Q
    188         ;
     1PSOCIDC2 ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm
     2 ;;7.0;OUTPATIENT PHARMACY;**226**;DEC 1997
     3 ;External reference to ^XUSEC supported by DBIA 10076
     4 ;External reference to IBARX supported by DBIA 125
     5 ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
     6 ;
     7TOTAL ;
     8 N COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED
     9 I '$D(PSOVETS) S PSOVETS=0
     10 N I,J
     11 F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0
     12 S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT REL",PSODFN)) Q:'PSODFN  D
     13 .S COUNTED=0
     14 .F J="YR2004","YR2005","YR2006" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
     15 F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I))
     16 ;
     17 S (I,J)=-""
     18 I '$D(PSOCVETS) S PSOCVETS=0
     19 F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0
     20 S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN  D
     21 .S CCOUNTED=0
     22 .F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT
     23 F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I))
     24 ;
     25 S (I,J)=""
     26 I '$D(PSOUVETS) S PSOUVETS=0
     27 F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0
     28 S PSOUDFN=0 F  S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN  D
     29 .S UCOUNTED=0
     30 .F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT
     31 F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I))
     32 ;
     33 Q
     34 ;
     35CHECK ;check for ICD and IB nodes
     36 ;
     37 N PSOREF,PSOIB,PSOOICD,PSOBILLD
     38 S PSOREF=YY
     39 S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8)
     40 ; see if bill already exists
     41 I PSOREF=0 D
     42 . I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
     43 . S PSOREL=$P($G(^PSRX(RXP,2)),"^",13)
     44 I PSOREF>0 D
     45 . I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
     46 . S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
     47 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
     48 ;    if billed/RELEASED and no IBQ node for both sc<50 and nsc
     49 I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
     50 . I $TR(PSOOICD,"^")[1  S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
     51 . I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
     52 ;           find unbilled ones with an ICD node and no IBQ node.
     53 I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
     54 . Q:$TR(PSOOICD,"^")=""
     55 . S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
     56 I YY S PSOTRF=PSOTRF+1
     57 Q
     58 ;
     59CANCEL ;Cancel erroneous copays/set IBQ node if not there
     60 ;released rx's
     61 N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE
     62 N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB
     63 N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL
     64 S PSOTYPE="CAN"
     65 S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN  D  Q:STOP
     66 .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
     67 .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
     68 .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
     69 .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP  D
     70 ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
     71 ..S YY="" F  S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY=""  D
     72 ...S (SAVREF,PSOREF)=YY
     73 ...;  verify again that it was billed and not already cancelled
     74 ...S PSOBILLD=0
     75 ...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
     76 ...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
     77 ...Q:'PSOBILLD
     78 ...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3)
     79 ...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA=""
     80 ...D CHKACT
     81 ...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"")
     82 ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
     83 ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
     84 ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ
     85 ...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
     86 ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
     87 ...D ACCUM
     88 ;
     89 ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased.
     90 S PSOTYP="IBQ"
     91 S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN  D  Q:STOP
     92 .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
     93 .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
     94 .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
     95 .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP  D
     96 ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
     97 ..S YY="" F  S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY=""  D
     98 ...S (SAVREF,PSOREF)=YY
     99 ...D SITE
     100 ...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3)
     101 ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
     102 ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
     103 ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D   ;don't want to set again if already did it as part of copay cancel
     104 ....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I  S IFN=I
     105 ....S COM=" BKGD CIDC UPDATE"
     106 ....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM
     107 ....K DA
     108 ....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
     109 ...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM
     110 ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
     111 Q
     112 ;
     113CHKACT ;check activity log for prev entry
     114 N ZACT,ZPSI,ZACTI
     115 S ZPSI=0 F  S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI=""  S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D  Q:$G(ZACT)
     116 . I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q
     117 I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C"
     118 Q
     119 ;
     120SETIBQ ; get data from IBQ node, set IBQ node, and 1st piece of IB node
     121 K PSOANSQ
     122 N PSONIBQ
     123 F PSOTYP=1:1:7 D
     124 . I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP)
     125 . I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP)
     126 . I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP)
     127 . I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP)
     128 . I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP)
     129 . I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP)
     130 . I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP)
     131 S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")
     132 Q
     133 ;
     134ACCUM ; ACCUMULATE TOTALS
     135 S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)=""
     136 ; get finished, but unreleased totals
     137 I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR=""  D  S PSOYEAR="" Q
     138 .S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR=""
     139 .S PSOCHRG=7
     140 .I PSOYEAR="YR2006" S PSOCHRG=8
     141 .S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR))
     142 .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
     143 .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1
     144 .S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
     145 .S PSONAM=$E(PSONAM,1,6)
     146 .S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD
     147 ;for released ones
     148 S PSOYR=$E(PSOREL,1,3)
     149 S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
     150 Q:PSOYEAR=""
     151 S PSOCHRG=7
     152 I PSOYEAR="YR2006" S PSOCHRG=8
     153 ;
     154 ;get Xtmp billing amt which would be IBAM tot + any previous refills
     155 S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR))
     156 ;
     157 ;if none yet then init to the IBAM total for the year
     158 I 'PSOTOT D
     159 .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ  D
     160 ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
     161 ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
     162 ;
     163 ;update Xtmp tot nodes with current fill amounts
     164 ;  note:  cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3
     165 ;             routine.  Cancelled copays are denoted with an asterisk.
     166 S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
     167 S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1
     168 ;
     169 ;indicate COPAY CANCEL for this fill
     170 ;       ;by adding to Xtmp "BILLED"
     171 S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
     172 S PSONAM=$E(PSONAM,1,6)
     173 S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
     174 ;
     175CAN I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D
     176 . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
     177 . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1
     178 Q
     179 ;
     180SITE ; SET UP VARIABLES NEEDED BY BILLING
     181 S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
     182 Q:PSOSITE=""
     183 S PSOPAR=$G(^PS(59,PSOSITE,1))
     184 S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
     185 S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
     186 Q
     187 ;
Note: See TracChangeset for help on using the changeset viewer.