RMPRPF2 ;HOIFO/TH,DDA - PFSS CHARGE ;8/18/05
;;3.0;PROSTHETICS;**98**;Feb 09, 1996
;
; This routine gets and stores a PFSS Charge ID, send charge message
; and updated charge to IBB.
;
; DBIA # 4665 for GETCHGID^IBBAPI and CHARGE^IBBAPI
Q
;
EN ; Entry Point
; Quit if no Delivery Date
I $P(^RMPR(660,RMPRDA,0),U,12)="" D DELAPD^RMPRPF1 Q
; If no PFSS Account Reference, then attempt to get one
I $P(^RMPR(660,RMPRDA,"PFSS"),U,1)="" D
. S RMPRSWDT=$P($$SWSTAT^IBBAPI(),"^",2)
. ; quit if Delivery Date is not after PFSS Switch On date.
. Q:$P(^RMPR(660,RMPRDA,0),"^",12)<RMPRSWDT
. D EN2^RMPRPF1
. Q
; If still no PFSS Account Reference, then record is not valid for PFSS- QUIT
I $P(^RMPR(660,RMPRDA,"PFSS"),U,1)="" D DELAPD^RMPRPF1 Q
;
S RMPRFLAG=1
; After Charge Msg sent (Charge ID exists); kill APD x-ref
; if PSAS HCPCS did not get updated AND
; if QTY did not get updated AND
; if Total Cost did not get updated AND
; if Ordering Provider did not get updated.
I $P(^RMPR(660,RMPRDA,"PFSS"),U,2)'="" D
. I $P($G(^RMPR(660,RMPRDA,1)),U,4)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,3) S RMPRFLAG=0 ; PSAS HCPCS
. E S RMPRFLAG=1 Q
. I $P(^RMPR(660,RMPRDA,0),U,7)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,4) S RMPRFLAG=0 ; QTY
. E S RMPRFLAG=1 Q
. I $P(^RMPR(660,RMPRDA,0),U,16)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,5) S RMPRFLAG=0 ; Total Cost
. E S RMPRFLAG=1 Q
. I $P($G(^RMPR(660,RMPRDA,10)),U,6)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,6) S RMPRFLAG=0 ; Ordering Provider
. E S RMPRFLAG=1 Q
I RMPRFLAG=0 D DELAPD^RMPRPF1
;
; Quit if QTY=0 or null
S (RMPRQTY,RMPRTC)=0
S RMPRQTY=$P(^RMPR(660,RMPRDA,0),U,7)
I RMPRQTY=0!(RMPRQTY="") D DELAPD^RMPRPF1 Q
; Quit if Total Cost=0 or null
S RMPRTC=$P(^RMPR(660,RMPRDA,0),U,16)
I RMPRTC=0!(RMPRTC="") D DELAPD^RMPRPF1 Q
;
I RMPRFLAG=1 D
. ; Check if PFSS Charge ID exists
. I $P($G(^RMPR(660,RMPRDA,"PFSS")),U,2)="" D GETUCID,STORE
. ; Get charge data
. D GETDATA
. ; Send charge data to IBB
. D SENDCHRG
. ; If charge msg was sent successfully,
. ; Update latest PSAS HCPCS, QTY, Total Cost, and Ordering Provider
. ; then kill the x-ref
. I RMPRCHRG'=0 D UPDATE D DELAPD^RMPRPF1
D EXIT
Q
;
GETUCID ; Obtain PFSS Charge ID
S RMPRUCID=""
S RMPRUCID=$$GETCHGID^IBBAPI()
Q
;
STORE ; Store PFSS Charge ID
L +^RMPR(660,RMPRDA)
S DIE="^RMPR(660,",DA=RMPRDA
S DR="101////^S X=RMPRUCID" D ^DIE
L -^RMPR(660,RMPRDA)
K DA,DIE,DR
Q
;
GETDATA ; Get Charge Data
S RMPRDFN=$P(^RMPR(660,RMPRDA,0),U,2) ; Patient ID
S RMPRARFN=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,1) ; PFSS Acct Ref
S RMPRTYPE="CG" ; Charge Type = Debit
S RMPRUCID=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,2) ; PFSS Charge ID
;
; FT1
S RMPRDEL=$P(^RMPR(660,RMPRDA,0),U,12)
S RMPRFT1(4)=RMPRDEL ; Delivery Date
S RMPRFT1(10)=RMPRQTY ; Transaction Quantity
S RMPRFT1(13)=423 ; Department Code
; Ordering Provider/Ordered by Code
S RMPRORD=$P($G(^RMPR(660,RMPRDA,10)),U,6)
S RMPRFT1(21)=RMPRORD
; Unit Cost = Total Cost/QTY
S RMPRFT1(22)=RMPRTC/RMPRQTY
;
; PR1
S RMPRHCPC=$P($G(^RMPR(660,RMPRDA,1)),"^",4)
S RMPRHCDT=$P(^RMPR(660,RMPRDA,0),"^")
D PSASHCPC^RMPOPF
S RMPRPR1(3)=RMPRVHC ; Procedure Code
S RMPRPR1(4)=RMPRTHC ; PSAS HCPCS text
; Procedure Functional Type - I:Stock Issue;P:Purchasing
S RMPRPFT="",RMPRPFT=$S($P(^RMPR(660,RMPRDA,0),U,13)=11:"I",1:"P")
S RMPRPR1(6)=RMPRPFT
;
; PROS
S (RMPRVNDR,RMPROBL)=""
S RMPRVNDR=$P(^RMPR(660,RMPRDA,0),U,9)
S RMPRPROS(1)=RMPRVNDR ; Vendor
S RMPROBL=$E($P($G(^RMPR(660,RMPRDA,1)),U,1),1,30)
S RMPRPROS(2)=RMPROBL ; OBL#
;
DG1ZCL ; SET UP DATA FOR DG1 AND ZCL
S RMPRBA1=$G(^RMPR(660,RMPRDA,"BA1"))
S RMPRBA2=$G(^RMPR(660,RMPRDA,"BA2"))
S RMPRBA3=$G(^RMPR(660,RMPRDA,"BA3"))
S RMPRBA4=$G(^RMPR(660,RMPRDA,"BA4"))
S RMPRDIAG=$P($G(^RMPR(660,RMPRDA,10)),"^",8)
S RMPRICDT=$P(^RMPR(660,RMPRDA,0),"^")
F I=1:1:4 D
.; DG1
.;CSV CHECK
.S RMPRDRG=$P(@("RMPRBA"_I),"^")
.S:+RMPRDRG RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDRG,0)),"^"),RMPRICDT)
.Q:+RMPRDRG=0
.S RMPRDG1(I,3)=$P(RMPRDRG,"^",2) ; Diagnosis Code
.S RMPRDG1(I,6)="F" ; Diagnosis Type
.;
.; ZCL
.F J=2:1:8 I $P(@("RMPRBA"_I),"^",J)'="" D
..; Set type and value. Overwrite null and zero values
..S:+$G(RMPRZCL(J-1,3))=0 RMPRZCL(J-1,2)=J-1,RMPRZCL(J-1,3)=$P(@("RMPRBA"_I),"^",J)
..Q
.Q
; IF NO CONSULT DIAG, USE PROSTHETICS ONE
I $G(RMPRDG1(1,3))="" D
.S RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDIAG,0)),"^"),RMPRICDT)
.Q:+RMPRDRG=0
.S RMPRDG1(1,3)=$P(RMPRDRG,"^",2),RMPRDG1(1,6)="F"
.Q
Q
;
SENDCHRG ; Send Charge Data
S RMPRCHRG=""
S RMPRCHRG=$$CHARGE^IBBAPI(RMPRDFN,RMPRARFN,RMPRTYPE,RMPRUCID,.RMPRFT1,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","",.RMPRPROS)
Q
;
UPDATE ; Update latest fields
L +^RMPR(660,RMPRDA)
; Store updates 102-latest PSAS HCPCS; 103-latest QTY; 104-latest Total Cost;
; 105-latest Ordering Provider
S DIE="^RMPR(660,",DA=RMPRDA
S DR="102////^S X=RMPRHCPC;103////^S X=RMPRQTY;104////^S X=RMPRTC;"
S DR=DR_"105////^S X=RMPRORD"
D ^DIE
L -^RMPR(660,RMPRDA)
K DA,DIE,DR
Q
;
EXIT ; Common exit point
K RMPRFLAG,RMPRQTY,RMPRTC,RMPRCHRG,RMPRUCID,RMPRDFN
K RMPRARFN,RMPRTYPE,RMPRFT1,RMPRPR1,RMPRCPT,RMPRRICP
K RMPRDG1,RMPRDIAG,RMPRZCL,RMPRNODE,RMPRPROS,RMPRHCPC
K RMRICPP,RMPRCPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPF2 5461 printed Dec 13, 2024@02:35:51 Page 2
RMPRPF2 ;HOIFO/TH,DDA - PFSS CHARGE ;8/18/05
+1 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
+2 ;
+3 ; This routine gets and stores a PFSS Charge ID, send charge message
+4 ; and updated charge to IBB.
+5 ;
+6 ; DBIA # 4665 for GETCHGID^IBBAPI and CHARGE^IBBAPI
+7 QUIT
+8 ;
EN ; Entry Point
+1 ; Quit if no Delivery Date
+2 IF $PIECE(^RMPR(660,RMPRDA,0),U,12)=""
DO DELAPD^RMPRPF1
QUIT
+3 ; If no PFSS Account Reference, then attempt to get one
+4 IF $PIECE(^RMPR(660,RMPRDA,"PFSS"),U,1)=""
Begin DoDot:1
+5 SET RMPRSWDT=$PIECE($$SWSTAT^IBBAPI(),"^",2)
+6 ; quit if Delivery Date is not after PFSS Switch On date.
+7 if $PIECE(^RMPR(660,RMPRDA,0),"^",12)<RMPRSWDT
QUIT
+8 DO EN2^RMPRPF1
+9 QUIT
End DoDot:1
+10 ; If still no PFSS Account Reference, then record is not valid for PFSS- QUIT
+11 IF $PIECE(^RMPR(660,RMPRDA,"PFSS"),U,1)=""
DO DELAPD^RMPRPF1
QUIT
+12 ;
+13 SET RMPRFLAG=1
+14 ; After Charge Msg sent (Charge ID exists); kill APD x-ref
+15 ; if PSAS HCPCS did not get updated AND
+16 ; if QTY did not get updated AND
+17 ; if Total Cost did not get updated AND
+18 ; if Ordering Provider did not get updated.
+19 IF $PIECE(^RMPR(660,RMPRDA,"PFSS"),U,2)'=""
Begin DoDot:1
+20 ; PSAS HCPCS
IF $PIECE($GET(^RMPR(660,RMPRDA,1)),U,4)=$PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,3)
SET RMPRFLAG=0
+21 IF '$TEST
SET RMPRFLAG=1
QUIT
+22 ; QTY
IF $PIECE(^RMPR(660,RMPRDA,0),U,7)=$PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,4)
SET RMPRFLAG=0
+23 IF '$TEST
SET RMPRFLAG=1
QUIT
+24 ; Total Cost
IF $PIECE(^RMPR(660,RMPRDA,0),U,16)=$PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,5)
SET RMPRFLAG=0
+25 IF '$TEST
SET RMPRFLAG=1
QUIT
+26 ; Ordering Provider
IF $PIECE($GET(^RMPR(660,RMPRDA,10)),U,6)=$PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,6)
SET RMPRFLAG=0
+27 IF '$TEST
SET RMPRFLAG=1
QUIT
End DoDot:1
+28 IF RMPRFLAG=0
DO DELAPD^RMPRPF1
+29 ;
+30 ; Quit if QTY=0 or null
+31 SET (RMPRQTY,RMPRTC)=0
+32 SET RMPRQTY=$PIECE(^RMPR(660,RMPRDA,0),U,7)
+33 IF RMPRQTY=0!(RMPRQTY="")
DO DELAPD^RMPRPF1
QUIT
+34 ; Quit if Total Cost=0 or null
+35 SET RMPRTC=$PIECE(^RMPR(660,RMPRDA,0),U,16)
+36 IF RMPRTC=0!(RMPRTC="")
DO DELAPD^RMPRPF1
QUIT
+37 ;
+38 IF RMPRFLAG=1
Begin DoDot:1
+39 ; Check if PFSS Charge ID exists
+40 IF $PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,2)=""
DO GETUCID
DO STORE
+41 ; Get charge data
+42 DO GETDATA
+43 ; Send charge data to IBB
+44 DO SENDCHRG
+45 ; If charge msg was sent successfully,
+46 ; Update latest PSAS HCPCS, QTY, Total Cost, and Ordering Provider
+47 ; then kill the x-ref
+48 IF RMPRCHRG'=0
DO UPDATE
DO DELAPD^RMPRPF1
End DoDot:1
+49 DO EXIT
+50 QUIT
+51 ;
GETUCID ; Obtain PFSS Charge ID
+1 SET RMPRUCID=""
+2 SET RMPRUCID=$$GETCHGID^IBBAPI()
+3 QUIT
+4 ;
STORE ; Store PFSS Charge ID
+1 LOCK +^RMPR(660,RMPRDA)
+2 SET DIE="^RMPR(660,"
SET DA=RMPRDA
+3 SET DR="101////^S X=RMPRUCID"
DO ^DIE
+4 LOCK -^RMPR(660,RMPRDA)
+5 KILL DA,DIE,DR
+6 QUIT
+7 ;
GETDATA ; Get Charge Data
+1 ; Patient ID
SET RMPRDFN=$PIECE(^RMPR(660,RMPRDA,0),U,2)
+2 ; PFSS Acct Ref
SET RMPRARFN=$PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,1)
+3 ; Charge Type = Debit
SET RMPRTYPE="CG"
+4 ; PFSS Charge ID
SET RMPRUCID=$PIECE($GET(^RMPR(660,RMPRDA,"PFSS")),U,2)
+5 ;
+6 ; FT1
+7 SET RMPRDEL=$PIECE(^RMPR(660,RMPRDA,0),U,12)
+8 ; Delivery Date
SET RMPRFT1(4)=RMPRDEL
+9 ; Transaction Quantity
SET RMPRFT1(10)=RMPRQTY
+10 ; Department Code
SET RMPRFT1(13)=423
+11 ; Ordering Provider/Ordered by Code
+12 SET RMPRORD=$PIECE($GET(^RMPR(660,RMPRDA,10)),U,6)
+13 SET RMPRFT1(21)=RMPRORD
+14 ; Unit Cost = Total Cost/QTY
+15 SET RMPRFT1(22)=RMPRTC/RMPRQTY
+16 ;
+17 ; PR1
+18 SET RMPRHCPC=$PIECE($GET(^RMPR(660,RMPRDA,1)),"^",4)
+19 SET RMPRHCDT=$PIECE(^RMPR(660,RMPRDA,0),"^")
+20 DO PSASHCPC^RMPOPF
+21 ; Procedure Code
SET RMPRPR1(3)=RMPRVHC
+22 ; PSAS HCPCS text
SET RMPRPR1(4)=RMPRTHC
+23 ; Procedure Functional Type - I:Stock Issue;P:Purchasing
+24 SET RMPRPFT=""
SET RMPRPFT=$SELECT($PIECE(^RMPR(660,RMPRDA,0),U,13)=11:"I",1:"P")
+25 SET RMPRPR1(6)=RMPRPFT
+26 ;
+27 ; PROS
+28 SET (RMPRVNDR,RMPROBL)=""
+29 SET RMPRVNDR=$PIECE(^RMPR(660,RMPRDA,0),U,9)
+30 ; Vendor
SET RMPRPROS(1)=RMPRVNDR
+31 SET RMPROBL=$EXTRACT($PIECE($GET(^RMPR(660,RMPRDA,1)),U,1),1,30)
+32 ; OBL#
SET RMPRPROS(2)=RMPROBL
+33 ;
DG1ZCL ; SET UP DATA FOR DG1 AND ZCL
+1 SET RMPRBA1=$GET(^RMPR(660,RMPRDA,"BA1"))
+2 SET RMPRBA2=$GET(^RMPR(660,RMPRDA,"BA2"))
+3 SET RMPRBA3=$GET(^RMPR(660,RMPRDA,"BA3"))
+4 SET RMPRBA4=$GET(^RMPR(660,RMPRDA,"BA4"))
+5 SET RMPRDIAG=$PIECE($GET(^RMPR(660,RMPRDA,10)),"^",8)
+6 SET RMPRICDT=$PIECE(^RMPR(660,RMPRDA,0),"^")
+7 FOR I=1:1:4
Begin DoDot:1
+8 ; DG1
+9 ;CSV CHECK
+10 SET RMPRDRG=$PIECE(@("RMPRBA"_I),"^")
+11 if +RMPRDRG
SET RMPRDRG=$$STATCHK^ICDAPIU($PIECE($GET(^ICD9(RMPRDRG,0)),"^"),RMPRICDT)
+12 if +RMPRDRG=0
QUIT
+13 ; Diagnosis Code
SET RMPRDG1(I,3)=$PIECE(RMPRDRG,"^",2)
+14 ; Diagnosis Type
SET RMPRDG1(I,6)="F"
+15 ;
+16 ; ZCL
+17 FOR J=2:1:8
IF $PIECE(@("RMPRBA"_I),"^",J)'=""
Begin DoDot:2
+18 ; Set type and value. Overwrite null and zero values
+19 if +$GET(RMPRZCL(J-1,3))=0
SET RMPRZCL(J-1,2)=J-1
SET RMPRZCL(J-1,3)=$PIECE(@("RMPRBA"_I),"^",J)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 ; IF NO CONSULT DIAG, USE PROSTHETICS ONE
+23 IF $GET(RMPRDG1(1,3))=""
Begin DoDot:1
+24 SET RMPRDRG=$$STATCHK^ICDAPIU($PIECE($GET(^ICD9(RMPRDIAG,0)),"^"),RMPRICDT)
+25 if +RMPRDRG=0
QUIT
+26 SET RMPRDG1(1,3)=$PIECE(RMPRDRG,"^",2)
SET RMPRDG1(1,6)="F"
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
SENDCHRG ; Send Charge Data
+1 SET RMPRCHRG=""
+2 SET RMPRCHRG=$$CHARGE^IBBAPI(RMPRDFN,RMPRARFN,RMPRTYPE,RMPRUCID,.RMPRFT1,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","",.RMPRPROS)
+3 QUIT
+4 ;
UPDATE ; Update latest fields
+1 LOCK +^RMPR(660,RMPRDA)
+2 ; Store updates 102-latest PSAS HCPCS; 103-latest QTY; 104-latest Total Cost;
+3 ; 105-latest Ordering Provider
+4 SET DIE="^RMPR(660,"
SET DA=RMPRDA
+5 SET DR="102////^S X=RMPRHCPC;103////^S X=RMPRQTY;104////^S X=RMPRTC;"
+6 SET DR=DR_"105////^S X=RMPRORD"
+7 DO ^DIE
+8 LOCK -^RMPR(660,RMPRDA)
+9 KILL DA,DIE,DR
+10 QUIT
+11 ;
EXIT ; Common exit point
+1 KILL RMPRFLAG,RMPRQTY,RMPRTC,RMPRCHRG,RMPRUCID,RMPRDFN
+2 KILL RMPRARFN,RMPRTYPE,RMPRFT1,RMPRPR1,RMPRCPT,RMPRRICP
+3 KILL RMPRDG1,RMPRDIAG,RMPRZCL,RMPRNODE,RMPRPROS,RMPRHCPC
+4 KILL RMRICPP,RMPRCPT
+5 QUIT
