Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPF2

RMPRPF2.m

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