source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m@ 789

Last change on this file since 789 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 4.6 KB
Line 
1RMPRPCED ;Hines OIFO/RVD - Prosthetics/660/668/PCE DELETE ;7/30/02 09:39
2 ;;3.0;PROSTHETICS;**62,70,121,131**;Feb 09, 1996;Build 3
3 ;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE.
4 ;
5 ; This routine contains the code for deleting a Prosthetic visit in PCE.
6 ;
7 ;DBIA #1890 - this API is used to delete data from the VISIT file
8 ; (9000010) and V files from PCE module.
9 ;DBIA #10048 - fileman read on file 9.4.
10 ;
11DEL(RMIE60) ;delete PCE visit.
12 D NEWVAR
13 S (RMLOCK,RMERR)=0
14 I '$P($G(^RMPR(660,RMIE60,10)),U,12) G DEL68
15 S RMSRC="PROSTHETICS DATA"
16 S X="PROSTHETICS",DIC="^DIC(9.4," D ^DIC
17 I '$D(Y)!(Y<0) S RMERR=-1 G DELX
18 S RMPKG=+Y
19 I 'RMPKG S RMERR=-1 G DELX
20 ;
21 ; get PCE IEn from file #660.
22 S RMPCE=$P($G(^RMPR(660,RMIE60,10)),U,12)
23 I 'RMPCE S RMERR=-1 G DELX
24 I '$D(^AUPNVSIT(RMPCE,0)) G DEL68
25 ;
26DELVF ; Remove all workload data from the PCE visit file & related V files.
27 ; check if the visit is already in PCE and remove workload,
28 ; (sending RMPKG and RMSRC to ensure that only data that originally
29 ; came from PROSTHETICS will be removed).
30 ;
31 N RMPR,REDO,VEJD
32 S REDO=0
33DELVF1 S RMCHK=$$DELVFILE^PXAPI("ALL",.RMPCE,RMPKG,RMSRC,0,0,"")
34 I RMCHK'=1 D I REDO=1 G DELVF1
35 . Q:$P($G(^AUPNVSIT(RMPCE,0)),U,9)'=1!REDO
36 . S VEJD=$O(^VEJD(19610.5,"B",RMPCE,0)) Q:VEJD=""
37 . ;kill remaining dependent (DSS) to visit
38 . S DA=VEJD,DIK="^VEJD(19610.5," D ^DIK
39 . K DA,DIK
40 . I $P(^AUPNVSIT(RMPCE,0),U,9)=0 S REDO=1
41 I RMCHK'=1 W !!,"*** Error in deleting PCE visit !!",! S RMERR=-1 G DELX
42 ;
43DEL68 ; delete PCE info in file #668.
44 S RMAMIS=$G(^RMPR(660,RMIE60,"AMS"))
45 S RMIE68=$O(^RMPR(668,"F",RMIE60,0)) G:RMIE68="" DEL60
46 L +^RMPR(668,RMIE68):3 I $T=0 D ERR68 G DELX
47 S DA=$O(^RMPR(668,RMIE68,10,"B",RMIE60,0))
48 S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",10," D ^DIK
49 S RMAMIEN=$O(^RMPR(668,RMIE68,11,"B",RMAMIS,0))
50 S RMCNT=0
51 F I=0:0 S I=$O(^RMPR(668,RMIE68,10,"B",I)) Q:I'>0 D
52 .S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1
53 ;if no other line item of the same GROUPER #, then delete.
54 I RMCNT=1 D
55 .S DA=RMAMIEN
56 .S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11,"
57 .D ^DIK
58 L -^RMPR(668,RMIE68)
59 ;
60DEL60 ; delete PCE info in file #660.
61 ; lock file #660
62 L +^RMPR(660,RMIE60,10):3 I $T=0 D ERR60 G DELX
63 S RMARR(660,RMIE60_",",8.12)="@"
64 S RMARR(660,RMIE60_",",8.13)="@"
65 D FILE^DIE("","RMARR","")
66 L -^RMPR(660,RMIE60,10)
67 ;
68 ; exit delete
69DELX Q RMERR
70 ;
71ERR68 ; print error if unable to delete/update file #668.
72 W !!,"*** File #668 is locked, IEN = ",RMIE68,", PLEASE contact your IRM!!",!!
73 L -^RMPR(668,RMIE68)
74 S RMERR=-1
75 Q
76ERR60 ; print error if unable to delete/update file #660.
77 W !!,"*** File #660 is locked, IEN = ",RMIE60,", PLEASE contact your IRM!!",!!
78 S RMERR=-1
79 Q
80 ;
81CHECK ;check for return error from PCE
82 ;input variable RMPROB
83 I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D
84 .S (R2,R3,RMMESS)=""
85 .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
86 ..F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D
87 ...S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4)
88 ...W:RMMESS'="" !,"???? ",RMMESS
89 ...I (RMMESS["CPT")!(RMMESS["Provider") S RMPRCPER=1
90 Q
91 ;
92PRV ;PROVIDER VALIDATION PRIOR TO PCE INTERFACE CALL
93 K PXAA,PXADI,PXAERR N PXAVDATE,PXAERRF
94 S PXAA("NAME")=^TMP("RMPRPCE1",$J,"PXAPI","PROVIDER",1,"NAME"),PXAVDATE=$P(^TMP("RMPRPCE1",$J,"PXAPI","ENCOUNTER",1,"ENC D/T"),".")
95 ;CHECKER
96 ;----Missing a pointer to providers name
97 I $G(PXAA("NAME"))']"" D G PRVX:$G(STOP)
98 .S STOP=1 ;--USED TO STOP DO LOOP
99 .S PXAERRF=1 ;--FLAG INDICATES THERE IS AN ERR
100 .S PXADI("DIALOG")=8390001.001
101 .S PXAERR(9)="NAME"
102 .S PXAERR(11)=$G(PXAA("NAME"))
103 .S PXAERR(12)="You are missing a pointer to the NEW PERSON file #200 that represents the Provider's name"
104 ;
105 ;----Not a pointer to NEW PERSON file#200
106 I $G(PXAA("NAME"))'["@" D 01^PXAIUPRV($G(PXAA("NAME"))) I $G(PXAIVAL)=1 K PXAIVAL,PXCA("ERROR") D G PRVX:$G(STOP)
107 .S STOP=1
108 .S PXAERRF=1
109 .S PXADI("DIALOG")=8390001.001
110 .S PXAERR(9)="NAME"
111 .S PXAERR(11)=$G(PXAA("NAME"))
112 .S PXAERR(12)=PXAERR(11)_" is NOT a pointer value to the NEW PERSON file #200 for Provider"
113 ;
114 ;----Not have an active person class
115 N CLASS
116 S CLASS=+$$GET^XUA4A72($G(PXAA("NAME")),PXAVDATE) I CLASS<0 D
117 .S STOP=1
118 .S PXAERRF=1
119 .S PXADI("DIALOG")=8390001.001
120 .S PXAERR(9)="NAME"
121 .S PXAERR(11)=$G(PXAA("NAME"))
122 .S PXAERR(12)="The Provider does not have an ACTIVE person class!"
123PRVX I STOP D
124 . S RMERR=0 K RMPCE
125 . S RMPROB($J,2,"ERROR1","PROVIDER","NAME",1)=PXAERR(12)
126 K PXAERR,PXAERRF,PXADI,PXAA
127 Q
128NEWVAR ; new variables
129 N Y
130 N I,RMCHK,RMKI,RMSUB,RMARR,DIE,DA,DIC,RMAMIS,RMAMIS68,DIK,RMCNT,RMAMIEN
131 Q
Note: See TracBrowser for help on using the repository browser.