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

RMPRPF1.m

Go to the documentation of this file.
  1. RMPRPF1 ;HOIFO/TH,DDA - PFSS Account Creation ;8/18/05
  1. ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
  1. ;
  1. ; This routine collects PFSS Account Creation required data elements,
  1. ; sends pre-cert or update message to IBB; obtains and stores a PFSS
  1. ; Account Reference in file 660.
  1. ;
  1. ; DBIA #4664 for GETACCT^IBBAPI
  1. ; DBIA #1997 for STATCHK^ICPTAPIU
  1. Q
  1. ;
  1. EN ; Entry Point
  1. S OK=1
  1. S RMPRSWDT=$P($$SWSTAT^IBBAPI(),"^",2)
  1. ; Quit if Entry Date is before PFSS Switch on date
  1. I $P(^RMPR(660,RMPRDA,0),"^")<RMPRSWDT D DELAPH Q
  1. EN2 ; Entry to be used if Delivery Date is greater than PFSS Switch on date
  1. ; Quit if PFSS Charge ID exists
  1. I $P(^RMPR(660,RMPRDA,"PFSS"),U,2)'="" D DELAPH Q
  1. ; Quit if Historical Data
  1. I $P(^RMPR(660,RMPRDA,0),U,13)=13 D DELAPH Q
  1. ; Quit if Shipping Charge exists
  1. I $P(^RMPR(660,RMPRDA,0),U,17)>0 D DELAPH Q
  1. S RMPREVNT="A05" ; Pre-cert
  1. ; Check if PFSS Account Ref exists
  1. S OK=1
  1. I $P(^RMPR(660,RMPRDA,"PFSS"),U,1)'="" D
  1. . ; Quit if PSAS HCPCS did not get updated
  1. . I $P(^RMPR(660,RMPRDA,1),U,4)=$P(^RMPR(660,RMPRDA,"PFSS"),U,3) D DELAPH S OK=0 Q
  1. . S RMPREVNT="A08" ; Update Patient Info
  1. I OK D
  1. . D GETDATA
  1. . D GETACCT
  1. . ; If msg was sent successfully, store data and kill x-ref
  1. . I RMPRARFN'=0 D
  1. . . D STORE
  1. . . D DELAPH
  1. D EXIT
  1. Q
  1. ;
  1. GETDATA ; Get pre-cert data
  1. S (RMPRDFN,RMPRARFN,RMPRAPLR)=""
  1. S RMPRDFN=$P(^RMPR(660,RMPRDA,0),U,2) ; Patient ID
  1. S RMPRAPLR="GETACCT;RMPRPF1"
  1. I RMPREVNT="A08",($P(^RMPR(660,RMPRDA,"PFSS"),U,1)'="") D
  1. . S RMPRARFN=$P(^RMPR(660,RMPRDA,"PFSS"),U,1) ; Acct Ref
  1. ;
  1. ; PV1
  1. S RMPRPV1(2)="O" ; Patient Class
  1. S RMPRSTA=$P(^RMPR(660,RMPRDA,0),U,10)
  1. D GETSITE
  1. S RMPRPV1(3)=RMPRHLOC ; Patient Location
  1. S (RMPRORD,RMPRADDT)=""
  1. S RMPRORD=$P($G(^RMPR(660,RMPRDA,10)),U,6)
  1. S RMPRPV1(7)=RMPRORD ; Attending Physician
  1. S RMPRADDT=$P(^RMPR(660,RMPRDA,0),U,1)
  1. S RMPRPV1(44)=RMPRADDT ; Admit Date/Time
  1. ;
  1. ; PV2
  1. S RMPRPV2(8)=RMPRADDT ; Expected Admit Date/Time
  1. S RMPREXDT=""
  1. S RMPREXDT=$P($G(^RMPR(660,RMPRDA,10)),U,1)
  1. S RMPRPV2(46)=$P(RMPREXDT,".",1) ; Patient Status Effective Date
  1. ;
  1. ; PR1
  1. S RMPRHCPC=$P(^RMPR(660,RMPRDA,1),U,4) ; PSAS HCPCS
  1. S RMPRHCDT=RMPRADDT ;Event date
  1. D PSASHCPC^RMPOPF ;CSV check; return RMPRVHC and RMPRTHC.
  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 RMPRPR1(6)=$S($P(^RMPR(660,RMPRDA,0),U,13)=11:"I",1:"P")
  1. ;
  1. ; DG1 AND ZCL
  1. D DG1ZCL^RMPRPF2
  1. Q
  1. ;
  1. GETSITE ; Get Patient Location
  1. ; requires RMPRSTA=file 4 pointer
  1. ; return RMPRHLOC= hospital location or NULL if there is none.
  1. S RMPRHLOC="",RMPRSIEN=""
  1. F S RMPRSIEN=$O(^RMPR(669.9,"C",RMPRSTA,RMPRSIEN)) Q:RMPRSIEN'>0 D
  1. .S RMPRHLOC=$P(^RMPR(669.9,RMPRSIEN,"PCE"),U,3)
  1. .Q
  1. I RMPRHLOC="" D
  1. .S RMPRSIEN=0
  1. .F S RMPRSIEN=$O(^RMPR(669.9,RMPRSIEN)) Q:(RMPRSIEN'>0)!(+RMPRHLOC) D
  1. ..S RMPRHLOC=$P(^RMPR(669.9,RMPRSIEN,"PCE"),U,3)
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. GETACCT ; Call GETACCT^IBBAPI to send data and get PFSS Account Reference
  1. S RMPRARFN=$$GETACCT^IBBAPI(RMPRDFN,RMPRARFN,RMPREVNT,RMPRAPLR,.RMPRPV1,.RMPRPV2,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","")
  1. Q
  1. ;
  1. STORE ; Store data
  1. S (RMPRQTY,RMPRTC)=""
  1. S RMPRQTY=$P(^RMPR(660,RMPRDA,0),U,7) ; QTY
  1. S RMPRTC=$P(^RMPR(660,RMPRDA,0),U,16) ; Total Cost
  1. ;
  1. L +^RMPR(660,RMPRDA)
  1. ; Store 100-PFSS Account Reference; 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="100////^S X=RMPRARFN;102////^S X=RMPRHCPC;"
  1. S DR=DR_"103////^S X=RMPRQTY;104////^S X=RMPRTC;105////^S X=RMPRORD"
  1. D ^DIE
  1. L -^RMPR(660,RMPRDA)
  1. K DA,DIE,DR
  1. Q
  1. ;
  1. DELAPD ; Delete the "APD" Flag
  1. S DIE="^RMPR(660,"
  1. S DA=RMPRDA
  1. S DR="107///@"
  1. D ^DIE
  1. K DIE,DA,DR
  1. Q
  1. ;
  1. DELAPH ; Delete the "APH" Flag
  1. S DIE="^RMPR(660,"
  1. S DA=RMPRDA
  1. S DR="106///@"
  1. D ^DIE
  1. K DIE,DA,DR
  1. Q
  1. EXIT ; Exit
  1. K OK,RMPREVNT,RMPRARFN,RMPRDFN,RMPRAPLR,RMPRPR1,RMPRSTA
  1. K RMPRPV1,RMPRHLOC,RMPRORD,RMPRADDT,RMPRSIEN,RMPRHCPC
  1. K RMPRPV2,RMPREXDT,RMPRDG1,RMPRDIAG,RMPRRICP,RMRICPP
  1. K RMPRZCL,RMPRNODE,RMPRQTY,RMPRTC,RMPRCPT,RMPRSWDT
  1. Q