PSOCP1.m

PSOCP1 ;BHAM ISC/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB (CONT'D) ;12/12/02

 ;;7.0;OUTPATIENT PHARMACY;**137,239,225**;DEC 1997;Build 29

 ;

 ;REF/IA

 ;IBARX/125

CHKIB ; SEE IF BILL # IS A CHARGE OR CANCELLATION #

 N IBN,XX

 I PSOREF=0 S XX=$G(^PSRX(RXP,"IB")) I $P(XX,"^",4)'="" S PSOIB=1 Q  ;ALREADY BILLED

 I PSOREF=0 S IBN=$P(XX,"^",2)

 I PSOREF'=0 S XX=$G(^PSRX(RXP,1,PSOREF,"IB")) I $P(XX,"^",2)'="" S PSOIB=1 Q  ;ALREADY BILLED

 I PSOREF'=0 S IBN=$P(XX,"^",1)

 I IBN'="" D STATUS

 Q

 ;

STATUS ;

 N XX

 S XX=$$STATUS^IBARX(IBN)

 I XX'=1,XX'=3 Q

 S PSOIB=1 ; ALREADY BILLED

 Q

 ;

XTYPE1 ;

 N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY

 S (X,PSOSCMX,SAVY)=""

 S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))

 I $P(PSOCIBQ,"^",1)'=1 Q

 S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q

 I 'X Q

 S X=X_"^"_PSOCPN D XTYPE^IBARX

 I $G(Y)'=1 Q

 S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S SAVY=I,I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I

 I PSOSCMX="",SAVY=0 Q  ; INCOME EXEMPT OR SERVICE-CONNECTED

 I PSOSCMX=2 Q  ; NEED TO ASK SC QUESTION

 ; If get to here, service-connected question does not apply for this patient anymore.  Update "IBQ" and CPRS

 S $P(^PSRX(RXP,"IBQ"),"^",1)="",CHKXTYPE=1

 D EN^PSOHLSN1(RXP,"XX","","Order edited")

 Q

 ;

SETCOMM ;

 I EXMT="SC" S PSOCOMM="Service Connected" Q

 I EXMT="CV" S PSOCOMM="COMBAT VETERAN" Q

 I EXMT="AO" S PSOCOMM="AGENT ORANGE RELATED" Q

 I EXMT="IR" S PSOCOMM="IONIZING RAD RELATED" Q

 I EXMT="EC" S PSOCOMM="SW ASIA COND. RELATED" Q

 I EXMT="SHAD" S PSOCOMM="PROJ 112/SHAD" Q

 I EXMT="MST" S PSOCOMM="MILITARY SEXUAL TRAUMA" Q

 I EXMT="HNC" S PSOCOMM="Head and/or Neck Cancer" Q

 Q

 ;

ICD ;

 S PSOCIBQ=$P(ZXX,U,4)_"^"_$P(ZXX,U,6)_"^"_$P(ZXX,U,2)_"^"_$P(ZXX,U,3)_"^"_$P(ZXX,U,5)_"^"_$P(ZXX,U,7)_"^"_$P(ZXX,U,8)_"^"_$P(ZXX,U,9)

 Q

 ;

PSOCP1    ;BHAM ISC/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB (CONT'D) ;12/12/02

 +1       ;;7.0;OUTPATIENT PHARMACY;**137,239,225**;DEC 1997;Build 29

 +2       ;

 +3       ;REF/IA

 +4       ;IBARX/125

CHKIB     ; SEE IF BILL # IS A CHARGE OR CANCELLATION #

 +1        NEW IBN,XX

 +2       ;ALREADY BILLED

           IF PSOREF=0

               SET XX=$GET(^PSRX(RXP,"IB"))

               IF $PIECE(XX,"^",4)'=""

                   SET PSOIB=1

                   QUIT 

 +3        IF PSOREF=0

               SET IBN=$PIECE(XX,"^",2)

 +4       ;ALREADY BILLED

           IF PSOREF'=0

               SET XX=$GET(^PSRX(RXP,1,PSOREF,"IB"))

               IF $PIECE(XX,"^",2)'=""

                   SET PSOIB=1

                   QUIT 

 +5        IF PSOREF'=0

               SET IBN=$PIECE(XX,"^",1)

 +6        IF IBN'=""

               DO STATUS

 +7        QUIT 

 +8       ;

STATUS    ;

 +1        NEW XX

 +2        SET XX=$$STATUS^IBARX(IBN)

 +3        IF XX'=1

               IF XX'=3

                   QUIT 

 +4       ; ALREADY BILLED

           SET PSOIB=1

 +5        QUIT 

 +6       ;

XTYPE1    ;

 +1        NEW PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY

 +2        SET (X,PSOSCMX,SAVY)=""

 +3        SET PSOCIBQ=$GET(^PSRX(RXP,"IBQ"))

 +4        IF $PIECE(PSOCIBQ,"^",1)'=1

               QUIT 

 +5        SET J=0

           FOR 

               SET J=$ORDER(^PS(59,J))

               IF 'J

                   QUIT 

               IF +$GET(^(J,"IB"))

                   SET X=+^("IB")

                   QUIT 

 +6        IF 'X

               QUIT 

 +7        SET X=X_"^"_PSOCPN

           DO XTYPE^IBARX

 +8        IF $GET(Y)'=1

               QUIT 

 +9        SET J=""

           FOR 

               SET J=$ORDER(Y(J))

               IF 'J

                   QUIT 

               SET I=""

               FOR 

                   SET SAVY=I

                   SET I=$ORDER(Y(J,I))

                   IF I=""

                       QUIT 

                   IF I>0

                       SET PSOSCMX=I

 +10      ; INCOME EXEMPT OR SERVICE-CONNECTED

           IF PSOSCMX=""

               IF SAVY=0

                   QUIT 

 +11      ; NEED TO ASK SC QUESTION

           IF PSOSCMX=2

               QUIT 

 +12      ; If get to here, service-connected question does not apply for this patient anymore.  Update "IBQ" and CPRS

 +13       SET $PIECE(^PSRX(RXP,"IBQ"),"^",1)=""

           SET CHKXTYPE=1

 +14       DO EN^PSOHLSN1(RXP,"XX","","Order edited")

 +15       QUIT 

 +16      ;

SETCOMM   ;

 +1        IF EXMT="SC"

               SET PSOCOMM="Service Connected"

               QUIT 

 +2        IF EXMT="CV"

               SET PSOCOMM="COMBAT VETERAN"

               QUIT 

 +3        IF EXMT="AO"

               SET PSOCOMM="AGENT ORANGE RELATED"

               QUIT 

 +4        IF EXMT="IR"

               SET PSOCOMM="IONIZING RAD RELATED"

               QUIT 

 +5        IF EXMT="EC"

               SET PSOCOMM="SW ASIA COND. RELATED"

               QUIT 

 +6        IF EXMT="SHAD"

               SET PSOCOMM="PROJ 112/SHAD"

               QUIT 

 +7        IF EXMT="MST"

               SET PSOCOMM="MILITARY SEXUAL TRAUMA"

               QUIT 

 +8        IF EXMT="HNC"

               SET PSOCOMM="Head and/or Neck Cancer"

               QUIT 

 +9        QUIT 

 +10      ;

ICD       ;

 +1        SET PSOCIBQ=$PIECE(ZXX,U,4)_"^"_$PIECE(ZXX,U,6)_"^"_$PIECE(ZXX,U,2)_"^"_$PIECE(ZXX,U,3)_"^"_$PIECE(ZXX,U,5)_"^"_$PIECE(ZXX,U,7)_"^"_$PIECE(ZXX,U,8)_"^"_$PIECE(ZXX,U,9)

 +2        QUIT 

 +3       ;