RMPRPCED ;Hines OIFO/RVD - Prosthetics/660/668/PCE DELETE ;7/30/02 09:39
;;3.0;PROSTHETICS;**62,70,121,131,141,145**;Feb 09, 1996;Build 6
;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE.
;
; This routine contains the code for deleting a Prosthetic visit in PCE.
;
;DBIA #1890 - this API is used to delete data from the VISIT file
; (9000010) and V files from PCE module.
;DBIA #10048 - fileman read on file 9.4.
;
DEL(RMIE60) ;delete PCE visit.
D NEWVAR
S (RMLOCK,RMERR)=0
G DEL68 ;Skip PCE delete for encounters created from items
I '$P($G(^RMPR(660,RMIE60,10)),U,12) G DEL68
S RMSRC="PROSTHETICS DATA"
S X="PROSTHETICS",DIC="^DIC(9.4," D ^DIC
I '$D(Y)!(Y<0) S RMERR=-1 G DELX
S RMPKG=+Y
I 'RMPKG S RMERR=-1 G DELX
;
; get PCE IEn from file #660.
S RMPCE=$P($G(^RMPR(660,RMIE60,10)),U,12)
I 'RMPCE S RMERR=-1 G DELX
I '$D(^AUPNVSIT(RMPCE,0)) G DEL68
;
DELVF ; Remove all workload data from the PCE visit file & related V files.
; check if the visit is already in PCE and remove workload,
; (sending RMPKG and RMSRC to ensure that only data that originally
; came from PROSTHETICS will be removed).
;
N RMPR,REDO,VEJD
S REDO=0
DELVF1 S RMCHK=$$DELVFILE^PXAPI("ALL",.RMPCE,RMPKG,RMSRC,0,0,"")
I RMCHK'=1 D I REDO=1 G DELVF1
. Q:$P($G(^AUPNVSIT(RMPCE,0)),U,9)'=1!REDO
. S VEJD=$O(^VEJD(19610.5,"B",RMPCE,0)) Q:VEJD=""
. ;kill remaining dependent (DSS) to visit
. S DA=VEJD,DIK="^VEJD(19610.5," D ^DIK
. K DA,DIK
. I $P(^AUPNVSIT(RMPCE,0),U,9)=0 S REDO=1
I RMCHK'=1 W !!,"*** Error in deleting PCE visit !!",! S RMERR=-1 G DELX
;
DEL68 ; delete PCE info in file #668.
S RMAMIS=$G(^RMPR(660,RMIE60,"AMS"))
S RMIE68=$O(^RMPR(668,"F",RMIE60,0)) G:RMIE68="" DEL60
L +^RMPR(668,RMIE68):3 I $T=0 D ERR68 G DELX
S DA=$O(^RMPR(668,RMIE68,10,"B",RMIE60,0))
S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",10," D ^DIK
S RMAMIEN=$O(^RMPR(668,RMIE68,11,"B",RMAMIS,0))
S RMCNT=0
F I=0:0 S I=$O(^RMPR(668,RMIE68,10,"B",I)) Q:I'>0 D
.S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1
;if no other line item of the same GROUPER #, then delete.
I RMCNT=1,RMAMIEN D
.S DA=RMAMIEN
.S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11,"
.D ^DIK
L -^RMPR(668,RMIE68)
;
DEL60 ; delete PCE info in file #660.
; lock file #660
L +^RMPR(660,RMIE60,10):3 I $T=0 D ERR60 G DELX
S RMARR(660,RMIE60_",",8.12)="@"
S RMARR(660,RMIE60_",",8.13)="@"
D FILE^DIE("","RMARR","")
L -^RMPR(660,RMIE60,10)
;
; exit delete
DELX Q RMERR
;
ERR68 ; print error if unable to delete/update file #668.
W !!,"*** File #668 is locked, IEN = ",RMIE68,", PLEASE contact your IRM!!",!!
L -^RMPR(668,RMIE68)
S RMERR=-1
Q
ERR60 ; print error if unable to delete/update file #660.
W !!,"*** File #660 is locked, IEN = ",RMIE60,", PLEASE contact your IRM!!",!!
S RMERR=-1
Q
;
CHECK ;check for return error from PCE
;input variable RMPROB
I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D
.S (R2,R3,RMMESS)=""
.F R1=0:0 S R1=$O(RMPROB($J,R1)) Q:R1'>0 F S R2=$O(RMPROB($J,R1,"ERROR1",R2)) Q:R2="" F S R3=$O(RMPROB($J,R1,"ERROR1",R2,R3)) Q:R3="" D
..F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D
...S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4)
...W:RMMESS'="" !,"???? ",RMMESS
...I (RMMESS["CPT")!(RMMESS["Provider") S RMPRCPER=1
Q
;
PRV ;PROVIDER VALIDATION PRIOR TO PCE INTERFACE CALL
K PXAA,PXADI,PXAERR N PXAVDATE,PXAERRF
S PXAA("NAME")=^TMP("RMPRPCE1",$J,"PXAPI","PROVIDER",1,"NAME"),PXAVDATE=$P(^TMP("RMPRPCE1",$J,"PXAPI","ENCOUNTER",1,"ENC D/T"),".")
;CHECKER
;----Missing a pointer to providers name
I $G(PXAA("NAME"))']"" D G PRVX:$G(STOP)
.S STOP=1 ;--USED TO STOP DO LOOP
.S PXAERRF=1 ;--FLAG INDICATES THERE IS AN ERR
.S PXADI("DIALOG")=8390001.001
.S PXAERR(9)="NAME"
.S PXAERR(11)=$G(PXAA("NAME"))
.S PXAERR(12)="You are missing a pointer to the NEW PERSON file #200 that represents the Provider's name"
;
;----Not a pointer to NEW PERSON file#200
I $G(PXAA("NAME"))'["@" D 01^PXAIUPRV($G(PXAA("NAME"))) I $G(PXAIVAL)=1 K PXAIVAL,PXCA("ERROR") D G PRVX:$G(STOP)
.S STOP=1
.S PXAERRF=1
.S PXADI("DIALOG")=8390001.001
.S PXAERR(9)="NAME"
.S PXAERR(11)=$G(PXAA("NAME"))
.S PXAERR(12)=PXAERR(11)_" is NOT a pointer value to the NEW PERSON file #200 for Provider"
;
;----Not have an active person class
N CLASS
S CLASS=+$$GET^XUA4A72($G(PXAA("NAME")),PXAVDATE) I CLASS<0 D
.S STOP=1
.S PXAERRF=1
.S PXADI("DIALOG")=8390001.001
.S PXAERR(9)="NAME"
.S PXAERR(11)=$G(PXAA("NAME"))
.S PXAERR(12)="The Provider does not have an ACTIVE person class!"
PRVX I STOP D
. S RMERR=0 K RMPCE
. S RMPROB($J,2,"ERROR1","PROVIDER","NAME",1)=PXAERR(12)
K PXAERR,PXAERRF,PXADI,PXAA
Q
NEWVAR ; new variables
N Y
N I,RMCHK,RMKI,RMSUB,RMARR,DIE,DA,DIC,RMAMIS,RMAMIS68,DIK,RMCNT,RMAMIEN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPCED 4905 printed Sep 23, 2025@20:11:54 Page 2
RMPRPCED ;Hines OIFO/RVD - Prosthetics/660/668/PCE DELETE ;7/30/02 09:39
+1 ;;3.0;PROSTHETICS;**62,70,121,131,141,145**;Feb 09, 1996;Build 6
+2 ;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE.
+3 ;
+4 ; This routine contains the code for deleting a Prosthetic visit in PCE.
+5 ;
+6 ;DBIA #1890 - this API is used to delete data from the VISIT file
+7 ; (9000010) and V files from PCE module.
+8 ;DBIA #10048 - fileman read on file 9.4.
+9 ;
DEL(RMIE60) ;delete PCE visit.
+1 DO NEWVAR
+2 SET (RMLOCK,RMERR)=0
+3 ;Skip PCE delete for encounters created from items
GOTO DEL68
+4 IF '$PIECE($GET(^RMPR(660,RMIE60,10)),U,12)
GOTO DEL68
+5 SET RMSRC="PROSTHETICS DATA"
+6 SET X="PROSTHETICS"
SET DIC="^DIC(9.4,"
DO ^DIC
+7 IF '$DATA(Y)!(Y<0)
SET RMERR=-1
GOTO DELX
+8 SET RMPKG=+Y
+9 IF 'RMPKG
SET RMERR=-1
GOTO DELX
+10 ;
+11 ; get PCE IEn from file #660.
+12 SET RMPCE=$PIECE($GET(^RMPR(660,RMIE60,10)),U,12)
+13 IF 'RMPCE
SET RMERR=-1
GOTO DELX
+14 IF '$DATA(^AUPNVSIT(RMPCE,0))
GOTO DEL68
+15 ;
DELVF ; Remove all workload data from the PCE visit file & related V files.
+1 ; check if the visit is already in PCE and remove workload,
+2 ; (sending RMPKG and RMSRC to ensure that only data that originally
+3 ; came from PROSTHETICS will be removed).
+4 ;
+5 NEW RMPR,REDO,VEJD
+6 SET REDO=0
DELVF1 SET RMCHK=$$DELVFILE^PXAPI("ALL",.RMPCE,RMPKG,RMSRC,0,0,"")
+1 IF RMCHK'=1
Begin DoDot:1
+2 if $PIECE($GET(^AUPNVSIT(RMPCE,0)),U,9)'=1!REDO
QUIT
+3 SET VEJD=$ORDER(^VEJD(19610.5,"B",RMPCE,0))
if VEJD=""
QUIT
+4 ;kill remaining dependent (DSS) to visit
+5 SET DA=VEJD
SET DIK="^VEJD(19610.5,"
DO ^DIK
+6 KILL DA,DIK
+7 IF $PIECE(^AUPNVSIT(RMPCE,0),U,9)=0
SET REDO=1
End DoDot:1
IF REDO=1
GOTO DELVF1
+8 IF RMCHK'=1
WRITE !!,"*** Error in deleting PCE visit !!",!
SET RMERR=-1
GOTO DELX
+9 ;
DEL68 ; delete PCE info in file #668.
+1 SET RMAMIS=$GET(^RMPR(660,RMIE60,"AMS"))
+2 SET RMIE68=$ORDER(^RMPR(668,"F",RMIE60,0))
if RMIE68=""
GOTO DEL60
+3 LOCK +^RMPR(668,RMIE68):3
IF $TEST=0
DO ERR68
GOTO DELX
+4 SET DA=$ORDER(^RMPR(668,RMIE68,10,"B",RMIE60,0))
+5 SET DA(1)=RMIE68
SET DIK="^RMPR(668,"_DA(1)_",10,"
DO ^DIK
+6 SET RMAMIEN=$ORDER(^RMPR(668,RMIE68,11,"B",RMAMIS,0))
+7 SET RMCNT=0
+8 FOR I=0:0
SET I=$ORDER(^RMPR(668,RMIE68,10,"B",I))
if I'>0
QUIT
Begin DoDot:1
+9 SET RMAMIS68=$GET(^RMPR(660,I,"AMS"))
if RMAMIS68=RMAMIS
SET RMCNT=RMCNT+1
End DoDot:1
+10 ;if no other line item of the same GROUPER #, then delete.
+11 IF RMCNT=1
IF RMAMIEN
Begin DoDot:1
+12 SET DA=RMAMIEN
+13 SET DA(1)=RMIE68
SET DIK="^RMPR(668,"_DA(1)_",11,"
+14 DO ^DIK
End DoDot:1
+15 LOCK -^RMPR(668,RMIE68)
+16 ;
DEL60 ; delete PCE info in file #660.
+1 ; lock file #660
+2 LOCK +^RMPR(660,RMIE60,10):3
IF $TEST=0
DO ERR60
GOTO DELX
+3 SET RMARR(660,RMIE60_",",8.12)="@"
+4 SET RMARR(660,RMIE60_",",8.13)="@"
+5 DO FILE^DIE("","RMARR","")
+6 LOCK -^RMPR(660,RMIE60,10)
+7 ;
+8 ; exit delete
DELX QUIT RMERR
+1 ;
ERR68 ; print error if unable to delete/update file #668.
+1 WRITE !!,"*** File #668 is locked, IEN = ",RMIE68,", PLEASE contact your IRM!!",!!
+2 LOCK -^RMPR(668,RMIE68)
+3 SET RMERR=-1
+4 QUIT
ERR60 ; print error if unable to delete/update file #660.
+1 WRITE !!,"*** File #660 is locked, IEN = ",RMIE60,", PLEASE contact your IRM!!",!!
+2 SET RMERR=-1
+3 QUIT
+4 ;
CHECK ;check for return error from PCE
+1 ;input variable RMPROB
+2 IF $DATA(RMPROB($JOB,1))!$DATA(RMPROB($JOB,2))
Begin DoDot:1
+3 SET (R2,R3,RMMESS)=""
+4 FOR R1=0:0
SET R1=$ORDER(RMPROB($JOB,R1))
if R1'>0
QUIT
FOR
SET R2=$ORDER(RMPROB($JOB,R1,"ERROR1",R2))
if R2=""
QUIT
FOR
SET R3=$ORDER(RMPROB($JOB,R1,"ERROR1",R2,R3))
if R3=""
QUIT
Begin DoDot:2
+5 FOR R4=0:0
SET R4=$ORDER(RMPROB($JOB,R1,"ERROR1",R2,R3,R4))
if R4'>0
QUIT
Begin DoDot:3
+6 SET RMMESS=RMPROB($JOB,R1,"ERROR1",R2,R3,R4)
+7 if RMMESS'=""
WRITE !,"???? ",RMMESS
+8 IF (RMMESS["CPT")!(RMMESS["Provider")
SET RMPRCPER=1
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
PRV ;PROVIDER VALIDATION PRIOR TO PCE INTERFACE CALL
+1 KILL PXAA,PXADI,PXAERR
NEW PXAVDATE,PXAERRF
+2 SET PXAA("NAME")=^TMP("RMPRPCE1",$JOB,"PXAPI","PROVIDER",1,"NAME")
SET PXAVDATE=$PIECE(^TMP("RMPRPCE1",$JOB,"PXAPI","ENCOUNTER",1,"ENC D/T"),".")
+3 ;CHECKER
+4 ;----Missing a pointer to providers name
+5 IF $GET(PXAA("NAME"))']""
Begin DoDot:1
+6 ;--USED TO STOP DO LOOP
SET STOP=1
+7 ;--FLAG INDICATES THERE IS AN ERR
SET PXAERRF=1
+8 SET PXADI("DIALOG")=8390001.001
+9 SET PXAERR(9)="NAME"
+10 SET PXAERR(11)=$GET(PXAA("NAME"))
+11 SET PXAERR(12)="You are missing a pointer to the NEW PERSON file #200 that represents the Provider's name"
End DoDot:1
if $GET(STOP)
GOTO PRVX
+12 ;
+13 ;----Not a pointer to NEW PERSON file#200
+14 IF $GET(PXAA("NAME"))'["@"
DO 01^PXAIUPRV($GET(PXAA("NAME")))
IF $GET(PXAIVAL)=1
KILL PXAIVAL,PXCA("ERROR")
Begin DoDot:1
+15 SET STOP=1
+16 SET PXAERRF=1
+17 SET PXADI("DIALOG")=8390001.001
+18 SET PXAERR(9)="NAME"
+19 SET PXAERR(11)=$GET(PXAA("NAME"))
+20 SET PXAERR(12)=PXAERR(11)_" is NOT a pointer value to the NEW PERSON file #200 for Provider"
End DoDot:1
if $GET(STOP)
GOTO PRVX
+21 ;
+22 ;----Not have an active person class
+23 NEW CLASS
+24 SET CLASS=+$$GET^XUA4A72($GET(PXAA("NAME")),PXAVDATE)
IF CLASS<0
Begin DoDot:1
+25 SET STOP=1
+26 SET PXAERRF=1
+27 SET PXADI("DIALOG")=8390001.001
+28 SET PXAERR(9)="NAME"
+29 SET PXAERR(11)=$GET(PXAA("NAME"))
+30 SET PXAERR(12)="The Provider does not have an ACTIVE person class!"
End DoDot:1
PRVX IF STOP
Begin DoDot:1
+1 SET RMERR=0
KILL RMPCE
+2 SET RMPROB($JOB,2,"ERROR1","PROVIDER","NAME",1)=PXAERR(12)
End DoDot:1
+3 KILL PXAERR,PXAERRF,PXADI,PXAA
+4 QUIT
NEWVAR ; new variables
+1 NEW Y
+2 NEW I,RMCHK,RMKI,RMSUB,RMARR,DIE,DA,DIC,RMAMIS,RMAMIS68,DIK,RMCNT,RMAMIEN
+3 QUIT
