- 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 Feb 19, 2025@00:02:19 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