- 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 Jan 18, 2025@03:36: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