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

RMPRPCED.m

Go to the documentation of this file.
  1. 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
  1. ;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE.
  1. ;
  1. ; This routine contains the code for deleting a Prosthetic visit in PCE.
  1. ;
  1. ;DBIA #1890 - this API is used to delete data from the VISIT file
  1. ; (9000010) and V files from PCE module.
  1. ;DBIA #10048 - fileman read on file 9.4.
  1. ;
  1. DEL(RMIE60) ;delete PCE visit.
  1. D NEWVAR
  1. S (RMLOCK,RMERR)=0
  1. G DEL68 ;Skip PCE delete for encounters created from items
  1. I '$P($G(^RMPR(660,RMIE60,10)),U,12) G DEL68
  1. S RMSRC="PROSTHETICS DATA"
  1. S X="PROSTHETICS",DIC="^DIC(9.4," D ^DIC
  1. I '$D(Y)!(Y<0) S RMERR=-1 G DELX
  1. S RMPKG=+Y
  1. I 'RMPKG S RMERR=-1 G DELX
  1. ;
  1. ; get PCE IEn from file #660.
  1. S RMPCE=$P($G(^RMPR(660,RMIE60,10)),U,12)
  1. I 'RMPCE S RMERR=-1 G DELX
  1. I '$D(^AUPNVSIT(RMPCE,0)) G DEL68
  1. ;
  1. 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,
  1. ; (sending RMPKG and RMSRC to ensure that only data that originally
  1. ; came from PROSTHETICS will be removed).
  1. ;
  1. N RMPR,REDO,VEJD
  1. S REDO=0
  1. DELVF1 S RMCHK=$$DELVFILE^PXAPI("ALL",.RMPCE,RMPKG,RMSRC,0,0,"")
  1. I RMCHK'=1 D I REDO=1 G DELVF1
  1. . Q:$P($G(^AUPNVSIT(RMPCE,0)),U,9)'=1!REDO
  1. . S VEJD=$O(^VEJD(19610.5,"B",RMPCE,0)) Q:VEJD=""
  1. . ;kill remaining dependent (DSS) to visit
  1. . S DA=VEJD,DIK="^VEJD(19610.5," D ^DIK
  1. . K DA,DIK
  1. . I $P(^AUPNVSIT(RMPCE,0),U,9)=0 S REDO=1
  1. I RMCHK'=1 W !!,"*** Error in deleting PCE visit !!",! S RMERR=-1 G DELX
  1. ;
  1. DEL68 ; delete PCE info in file #668.
  1. S RMAMIS=$G(^RMPR(660,RMIE60,"AMS"))
  1. S RMIE68=$O(^RMPR(668,"F",RMIE60,0)) G:RMIE68="" DEL60
  1. L +^RMPR(668,RMIE68):3 I $T=0 D ERR68 G DELX
  1. S DA=$O(^RMPR(668,RMIE68,10,"B",RMIE60,0))
  1. S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",10," D ^DIK
  1. S RMAMIEN=$O(^RMPR(668,RMIE68,11,"B",RMAMIS,0))
  1. S RMCNT=0
  1. F I=0:0 S I=$O(^RMPR(668,RMIE68,10,"B",I)) Q:I'>0 D
  1. .S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1
  1. ;if no other line item of the same GROUPER #, then delete.
  1. I RMCNT=1,RMAMIEN D
  1. .S DA=RMAMIEN
  1. .S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11,"
  1. .D ^DIK
  1. L -^RMPR(668,RMIE68)
  1. ;
  1. DEL60 ; delete PCE info in file #660.
  1. ; lock file #660
  1. L +^RMPR(660,RMIE60,10):3 I $T=0 D ERR60 G DELX
  1. S RMARR(660,RMIE60_",",8.12)="@"
  1. S RMARR(660,RMIE60_",",8.13)="@"
  1. D FILE^DIE("","RMARR","")
  1. L -^RMPR(660,RMIE60,10)
  1. ;
  1. ; exit delete
  1. DELX Q RMERR
  1. ;
  1. ERR68 ; print error if unable to delete/update file #668.
  1. W !!,"*** File #668 is locked, IEN = ",RMIE68,", PLEASE contact your IRM!!",!!
  1. L -^RMPR(668,RMIE68)
  1. S RMERR=-1
  1. Q
  1. ERR60 ; print error if unable to delete/update file #660.
  1. W !!,"*** File #660 is locked, IEN = ",RMIE60,", PLEASE contact your IRM!!",!!
  1. S RMERR=-1
  1. Q
  1. ;
  1. CHECK ;check for return error from PCE
  1. ;input variable RMPROB
  1. I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D
  1. .S (R2,R3,RMMESS)=""
  1. .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
  1. ..F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D
  1. ...S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4)
  1. ...W:RMMESS'="" !,"???? ",RMMESS
  1. ...I (RMMESS["CPT")!(RMMESS["Provider") S RMPRCPER=1
  1. Q
  1. ;
  1. PRV ;PROVIDER VALIDATION PRIOR TO PCE INTERFACE CALL
  1. K PXAA,PXADI,PXAERR N PXAVDATE,PXAERRF
  1. S PXAA("NAME")=^TMP("RMPRPCE1",$J,"PXAPI","PROVIDER",1,"NAME"),PXAVDATE=$P(^TMP("RMPRPCE1",$J,"PXAPI","ENCOUNTER",1,"ENC D/T"),".")
  1. ;CHECKER
  1. ;----Missing a pointer to providers name
  1. I $G(PXAA("NAME"))']"" D G PRVX:$G(STOP)
  1. .S STOP=1 ;--USED TO STOP DO LOOP
  1. .S PXAERRF=1 ;--FLAG INDICATES THERE IS AN ERR
  1. .S PXADI("DIALOG")=8390001.001
  1. .S PXAERR(9)="NAME"
  1. .S PXAERR(11)=$G(PXAA("NAME"))
  1. .S PXAERR(12)="You are missing a pointer to the NEW PERSON file #200 that represents the Provider's name"
  1. ;
  1. ;----Not a pointer to NEW PERSON file#200
  1. I $G(PXAA("NAME"))'["@" D 01^PXAIUPRV($G(PXAA("NAME"))) I $G(PXAIVAL)=1 K PXAIVAL,PXCA("ERROR") D G PRVX:$G(STOP)
  1. .S STOP=1
  1. .S PXAERRF=1
  1. .S PXADI("DIALOG")=8390001.001
  1. .S PXAERR(9)="NAME"
  1. .S PXAERR(11)=$G(PXAA("NAME"))
  1. .S PXAERR(12)=PXAERR(11)_" is NOT a pointer value to the NEW PERSON file #200 for Provider"
  1. ;
  1. ;----Not have an active person class
  1. N CLASS
  1. S CLASS=+$$GET^XUA4A72($G(PXAA("NAME")),PXAVDATE) I CLASS<0 D
  1. .S STOP=1
  1. .S PXAERRF=1
  1. .S PXADI("DIALOG")=8390001.001
  1. .S PXAERR(9)="NAME"
  1. .S PXAERR(11)=$G(PXAA("NAME"))
  1. .S PXAERR(12)="The Provider does not have an ACTIVE person class!"
  1. PRVX I STOP D
  1. . S RMERR=0 K RMPCE
  1. . S RMPROB($J,2,"ERROR1","PROVIDER","NAME",1)=PXAERR(12)
  1. K PXAERR,PXAERRF,PXADI,PXAA
  1. Q
  1. NEWVAR ; new variables
  1. N Y
  1. N I,RMCHK,RMKI,RMSUB,RMARR,DIE,DA,DIC,RMAMIS,RMAMIS68,DIK,RMCNT,RMAMIEN
  1. Q