RMPRPF1 ;HOIFO/TH,DDA - PFSS Account Creation ;8/18/05
;;3.0;PROSTHETICS;**98**;Feb 09, 1996
;
; This routine collects PFSS Account Creation required data elements,
; sends pre-cert or update message to IBB; obtains and stores a PFSS
; Account Reference in file 660.
;
; DBIA #4664 for GETACCT^IBBAPI
; DBIA #1997 for STATCHK^ICPTAPIU
Q
;
EN ; Entry Point
S OK=1
S RMPRSWDT=$P($$SWSTAT^IBBAPI(),"^",2)
; Quit if Entry Date is before PFSS Switch on date
I $P(^RMPR(660,RMPRDA,0),"^")<RMPRSWDT D DELAPH Q
EN2 ; Entry to be used if Delivery Date is greater than PFSS Switch on date
; Quit if PFSS Charge ID exists
I $P(^RMPR(660,RMPRDA,"PFSS"),U,2)'="" D DELAPH Q
; Quit if Historical Data
I $P(^RMPR(660,RMPRDA,0),U,13)=13 D DELAPH Q
; Quit if Shipping Charge exists
I $P(^RMPR(660,RMPRDA,0),U,17)>0 D DELAPH Q
S RMPREVNT="A05" ; Pre-cert
; Check if PFSS Account Ref exists
S OK=1
I $P(^RMPR(660,RMPRDA,"PFSS"),U,1)'="" D
. ; Quit if PSAS HCPCS did not get updated
. I $P(^RMPR(660,RMPRDA,1),U,4)=$P(^RMPR(660,RMPRDA,"PFSS"),U,3) D DELAPH S OK=0 Q
. S RMPREVNT="A08" ; Update Patient Info
I OK D
. D GETDATA
. D GETACCT
. ; If msg was sent successfully, store data and kill x-ref
. I RMPRARFN'=0 D
. . D STORE
. . D DELAPH
D EXIT
Q
;
GETDATA ; Get pre-cert data
S (RMPRDFN,RMPRARFN,RMPRAPLR)=""
S RMPRDFN=$P(^RMPR(660,RMPRDA,0),U,2) ; Patient ID
S RMPRAPLR="GETACCT;RMPRPF1"
I RMPREVNT="A08",($P(^RMPR(660,RMPRDA,"PFSS"),U,1)'="") D
. S RMPRARFN=$P(^RMPR(660,RMPRDA,"PFSS"),U,1) ; Acct Ref
;
; PV1
S RMPRPV1(2)="O" ; Patient Class
S RMPRSTA=$P(^RMPR(660,RMPRDA,0),U,10)
D GETSITE
S RMPRPV1(3)=RMPRHLOC ; Patient Location
S (RMPRORD,RMPRADDT)=""
S RMPRORD=$P($G(^RMPR(660,RMPRDA,10)),U,6)
S RMPRPV1(7)=RMPRORD ; Attending Physician
S RMPRADDT=$P(^RMPR(660,RMPRDA,0),U,1)
S RMPRPV1(44)=RMPRADDT ; Admit Date/Time
;
; PV2
S RMPRPV2(8)=RMPRADDT ; Expected Admit Date/Time
S RMPREXDT=""
S RMPREXDT=$P($G(^RMPR(660,RMPRDA,10)),U,1)
S RMPRPV2(46)=$P(RMPREXDT,".",1) ; Patient Status Effective Date
;
; PR1
S RMPRHCPC=$P(^RMPR(660,RMPRDA,1),U,4) ; PSAS HCPCS
S RMPRHCDT=RMPRADDT ;Event date
D PSASHCPC^RMPOPF ;CSV check; return RMPRVHC and RMPRTHC.
S RMPRPR1(3)=RMPRVHC ; Procedure code
S RMPRPR1(4)=RMPRTHC ; PSAS HCPCS text
; Procedure Functional Type - I:Stock Issue; P:Purchasing
S RMPRPR1(6)=$S($P(^RMPR(660,RMPRDA,0),U,13)=11:"I",1:"P")
;
; DG1 AND ZCL
D DG1ZCL^RMPRPF2
Q
;
GETSITE ; Get Patient Location
; requires RMPRSTA=file 4 pointer
; return RMPRHLOC= hospital location or NULL if there is none.
S RMPRHLOC="",RMPRSIEN=""
F S RMPRSIEN=$O(^RMPR(669.9,"C",RMPRSTA,RMPRSIEN)) Q:RMPRSIEN'>0 D
.S RMPRHLOC=$P(^RMPR(669.9,RMPRSIEN,"PCE"),U,3)
.Q
I RMPRHLOC="" D
.S RMPRSIEN=0
.F S RMPRSIEN=$O(^RMPR(669.9,RMPRSIEN)) Q:(RMPRSIEN'>0)!(+RMPRHLOC) D
..S RMPRHLOC=$P(^RMPR(669.9,RMPRSIEN,"PCE"),U,3)
..Q
.Q
Q
;
GETACCT ; Call GETACCT^IBBAPI to send data and get PFSS Account Reference
S RMPRARFN=$$GETACCT^IBBAPI(RMPRDFN,RMPRARFN,RMPREVNT,RMPRAPLR,.RMPRPV1,.RMPRPV2,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","")
Q
;
STORE ; Store data
S (RMPRQTY,RMPRTC)=""
S RMPRQTY=$P(^RMPR(660,RMPRDA,0),U,7) ; QTY
S RMPRTC=$P(^RMPR(660,RMPRDA,0),U,16) ; Total Cost
;
L +^RMPR(660,RMPRDA)
; Store 100-PFSS Account Reference; 102-latest PSAS HCPCS; 103-latest QTY; 104-latest Total Cost;
; 105-latest Ordering Provider
S DIE="^RMPR(660,",DA=RMPRDA
S DR="100////^S X=RMPRARFN;102////^S X=RMPRHCPC;"
S DR=DR_"103////^S X=RMPRQTY;104////^S X=RMPRTC;105////^S X=RMPRORD"
D ^DIE
L -^RMPR(660,RMPRDA)
K DA,DIE,DR
Q
;
DELAPD ; Delete the "APD" Flag
S DIE="^RMPR(660,"
S DA=RMPRDA
S DR="107///@"
D ^DIE
K DIE,DA,DR
Q
;
DELAPH ; Delete the "APH" Flag
S DIE="^RMPR(660,"
S DA=RMPRDA
S DR="106///@"
D ^DIE
K DIE,DA,DR
Q
EXIT ; Exit
K OK,RMPREVNT,RMPRARFN,RMPRDFN,RMPRAPLR,RMPRPR1,RMPRSTA
K RMPRPV1,RMPRHLOC,RMPRORD,RMPRADDT,RMPRSIEN,RMPRHCPC
K RMPRPV2,RMPREXDT,RMPRDG1,RMPRDIAG,RMPRRICP,RMRICPP
K RMPRZCL,RMPRNODE,RMPRQTY,RMPRTC,RMPRCPT,RMPRSWDT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPF1 4214 printed Dec 13, 2024@02:35:50 Page 2
RMPRPF1 ;HOIFO/TH,DDA - PFSS Account Creation ;8/18/05
+1 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
+2 ;
+3 ; This routine collects PFSS Account Creation required data elements,
+4 ; sends pre-cert or update message to IBB; obtains and stores a PFSS
+5 ; Account Reference in file 660.
+6 ;
+7 ; DBIA #4664 for GETACCT^IBBAPI
+8 ; DBIA #1997 for STATCHK^ICPTAPIU
+9 QUIT
+10 ;
EN ; Entry Point
+1 SET OK=1
+2 SET RMPRSWDT=$PIECE($$SWSTAT^IBBAPI(),"^",2)
+3 ; Quit if Entry Date is before PFSS Switch on date
+4 IF $PIECE(^RMPR(660,RMPRDA,0),"^")<RMPRSWDT
DO DELAPH
QUIT
EN2 ; Entry to be used if Delivery Date is greater than PFSS Switch on date
+1 ; Quit if PFSS Charge ID exists
+2 IF $PIECE(^RMPR(660,RMPRDA,"PFSS"),U,2)'=""
DO DELAPH
QUIT
+3 ; Quit if Historical Data
+4 IF $PIECE(^RMPR(660,RMPRDA,0),U,13)=13
DO DELAPH
QUIT
+5 ; Quit if Shipping Charge exists
+6 IF $PIECE(^RMPR(660,RMPRDA,0),U,17)>0
DO DELAPH
QUIT
+7 ; Pre-cert
SET RMPREVNT="A05"
+8 ; Check if PFSS Account Ref exists
+9 SET OK=1
+10 IF $PIECE(^RMPR(660,RMPRDA,"PFSS"),U,1)'=""
Begin DoDot:1
+11 ; Quit if PSAS HCPCS did not get updated
+12 IF $PIECE(^RMPR(660,RMPRDA,1),U,4)=$PIECE(^RMPR(660,RMPRDA,"PFSS"),U,3)
DO DELAPH
SET OK=0
QUIT
+13 ; Update Patient Info
SET RMPREVNT="A08"
End DoDot:1
+14 IF OK
Begin DoDot:1
+15 DO GETDATA
+16 DO GETACCT
+17 ; If msg was sent successfully, store data and kill x-ref
+18 IF RMPRARFN'=0
Begin DoDot:2
+19 DO STORE
+20 DO DELAPH
End DoDot:2
End DoDot:1
+21 DO EXIT
+22 QUIT
+23 ;
GETDATA ; Get pre-cert data
+1 SET (RMPRDFN,RMPRARFN,RMPRAPLR)=""
+2 ; Patient ID
SET RMPRDFN=$PIECE(^RMPR(660,RMPRDA,0),U,2)
+3 SET RMPRAPLR="GETACCT;RMPRPF1"
+4 IF RMPREVNT="A08"
IF ($PIECE(^RMPR(660,RMPRDA,"PFSS"),U,1)'="")
Begin DoDot:1
+5 ; Acct Ref
SET RMPRARFN=$PIECE(^RMPR(660,RMPRDA,"PFSS"),U,1)
End DoDot:1
+6 ;
+7 ; PV1
+8 ; Patient Class
SET RMPRPV1(2)="O"
+9 SET RMPRSTA=$PIECE(^RMPR(660,RMPRDA,0),U,10)
+10 DO GETSITE
+11 ; Patient Location
SET RMPRPV1(3)=RMPRHLOC
+12 SET (RMPRORD,RMPRADDT)=""
+13 SET RMPRORD=$PIECE($GET(^RMPR(660,RMPRDA,10)),U,6)
+14 ; Attending Physician
SET RMPRPV1(7)=RMPRORD
+15 SET RMPRADDT=$PIECE(^RMPR(660,RMPRDA,0),U,1)
+16 ; Admit Date/Time
SET RMPRPV1(44)=RMPRADDT
+17 ;
+18 ; PV2
+19 ; Expected Admit Date/Time
SET RMPRPV2(8)=RMPRADDT
+20 SET RMPREXDT=""
+21 SET RMPREXDT=$PIECE($GET(^RMPR(660,RMPRDA,10)),U,1)
+22 ; Patient Status Effective Date
SET RMPRPV2(46)=$PIECE(RMPREXDT,".",1)
+23 ;
+24 ; PR1
+25 ; PSAS HCPCS
SET RMPRHCPC=$PIECE(^RMPR(660,RMPRDA,1),U,4)
+26 ;Event date
SET RMPRHCDT=RMPRADDT
+27 ;CSV check; return RMPRVHC and RMPRTHC.
DO PSASHCPC^RMPOPF
+28 ; Procedure code
SET RMPRPR1(3)=RMPRVHC
+29 ; PSAS HCPCS text
SET RMPRPR1(4)=RMPRTHC
+30 ; Procedure Functional Type - I:Stock Issue; P:Purchasing
+31 SET RMPRPR1(6)=$SELECT($PIECE(^RMPR(660,RMPRDA,0),U,13)=11:"I",1:"P")
+32 ;
+33 ; DG1 AND ZCL
+34 DO DG1ZCL^RMPRPF2
+35 QUIT
+36 ;
GETSITE ; Get Patient Location
+1 ; requires RMPRSTA=file 4 pointer
+2 ; return RMPRHLOC= hospital location or NULL if there is none.
+3 SET RMPRHLOC=""
SET RMPRSIEN=""
+4 FOR
SET RMPRSIEN=$ORDER(^RMPR(669.9,"C",RMPRSTA,RMPRSIEN))
if RMPRSIEN'>0
QUIT
Begin DoDot:1
+5 SET RMPRHLOC=$PIECE(^RMPR(669.9,RMPRSIEN,"PCE"),U,3)
+6 QUIT
End DoDot:1
+7 IF RMPRHLOC=""
Begin DoDot:1
+8 SET RMPRSIEN=0
+9 FOR
SET RMPRSIEN=$ORDER(^RMPR(669.9,RMPRSIEN))
if (RMPRSIEN'>0)!(+RMPRHLOC)
QUIT
Begin DoDot:2
+10 SET RMPRHLOC=$PIECE(^RMPR(669.9,RMPRSIEN,"PCE"),U,3)
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
GETACCT ; Call GETACCT^IBBAPI to send data and get PFSS Account Reference
+1 SET RMPRARFN=$$GETACCT^IBBAPI(RMPRDFN,RMPRARFN,RMPREVNT,RMPRAPLR,.RMPRPV1,.RMPRPV2,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","")
+2 QUIT
+3 ;
STORE ; Store data
+1 SET (RMPRQTY,RMPRTC)=""
+2 ; QTY
SET RMPRQTY=$PIECE(^RMPR(660,RMPRDA,0),U,7)
+3 ; Total Cost
SET RMPRTC=$PIECE(^RMPR(660,RMPRDA,0),U,16)
+4 ;
+5 LOCK +^RMPR(660,RMPRDA)
+6 ; Store 100-PFSS Account Reference; 102-latest PSAS HCPCS; 103-latest QTY; 104-latest Total Cost;
+7 ; 105-latest Ordering Provider
+8 SET DIE="^RMPR(660,"
SET DA=RMPRDA
+9 SET DR="100////^S X=RMPRARFN;102////^S X=RMPRHCPC;"
+10 SET DR=DR_"103////^S X=RMPRQTY;104////^S X=RMPRTC;105////^S X=RMPRORD"
+11 DO ^DIE
+12 LOCK -^RMPR(660,RMPRDA)
+13 KILL DA,DIE,DR
+14 QUIT
+15 ;
DELAPD ; Delete the "APD" Flag
+1 SET DIE="^RMPR(660,"
+2 SET DA=RMPRDA
+3 SET DR="107///@"
+4 DO ^DIE
+5 KILL DIE,DA,DR
+6 QUIT
+7 ;
DELAPH ; Delete the "APH" Flag
+1 SET DIE="^RMPR(660,"
+2 SET DA=RMPRDA
+3 SET DR="106///@"
+4 DO ^DIE
+5 KILL DIE,DA,DR
+6 QUIT
EXIT ; Exit
+1 KILL OK,RMPREVNT,RMPRARFN,RMPRDFN,RMPRAPLR,RMPRPR1,RMPRSTA
+2 KILL RMPRPV1,RMPRHLOC,RMPRORD,RMPRADDT,RMPRSIEN,RMPRHCPC
+3 KILL RMPRPV2,RMPREXDT,RMPRDG1,RMPRDIAG,RMPRRICP,RMRICPP
+4 KILL RMPRZCL,RMPRNODE,RMPRQTY,RMPRTC,RMPRCPT,RMPRSWDT
+5 QUIT
