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