PXICLN9B ;ISL/dee - Cleanup routine for PX*1.0*9 ;11/8/96
;;1.0;PCE PATIENT CARE ENCOUNTER;**9**;Aug 12, 1996
;
CLEANUP ;
N PXICLN9 S PXICLN9=1 ;Flag that this job is running.
N PXIVSIT,PXIVDT,PXICPT,PXIFILE,PXIVFILE,PXIVIEN,PXICNT
N PXINODE,VSIT,PXINVSIT,PXITVSIT,PXIDEL
N PXITDUP,PXITCNT,PXITNODE
N PXISOR,PXIPKG,PXIHLOC,PXIOE
;
;Set up package and source for Rad and Lab
S PXISOR(1)=$$SOURCE^PXAPIUTL("RAD/NUC MED")
S PXISOR(2)=$$SOURCE^PXAPIUTL("LAB DATA")
S PXIPKG(1)=$$PKG2IEN^VSIT("RA")
S PXIPKG(2)=$$PKG2IEN^VSIT("LR")
S PXIPKG(0)="~"_PXIPKG(1)_"~"_PXIPKG(2)_"~"
;
;get clinic for lab data
S PXIHLOC(2)=+$G(^LAB(69.9,1,.8))
;
I $D(^TMP("PXICLN9")) D
. ;save data from where tasked errored out
. K ^TMP("PXK",$J)
. M ^TMP("PXK",$J)=^TMP("PXICLN9")
. K ^TMP("PXICLN9")
. D EN1^PXKMAIN
. K ^TMP("PXK",$J)
. D EVENT^PXKMAIN
;
;Where to start?
S PXIVSIT=+$G(^PX(815,1,"PATCH"))
I PXIVSIT<1 D
. S PXIVSIT=$O(^AUPNVSIT("A"),-1)
. I PXIVSIT>0 S PXIVSIT=PXIVSIT+1
. E S PXIVSIT=0
. S $P(^PX(815,1,"PATCH"),"^",1)=PXIVSIT
;
;*R "Visit ien: ",PXIVSIT ;*
;*D ;*
F S PXIVSIT=$O(^AUPNVSIT(PXIVSIT),-1) Q:'PXIVSIT D
. S PXICPT=$O(^AUPNVCPT("AD",PXIVSIT,0))
. S PXIPRV=$O(^AUPNVPRV("AD",PXIVSIT,0))
. I PXICPT S PXIPKG=$P($G(^AUPNVCPT(+PXICPT,812)),"^",2)
. E S PXIPKG=$P($G(^AUPNVPRV(+PXIPRV,812)),"^",2)
. ;
. ;Rad or Lab ?
. I (PXICPT!PXIPRV),PXIPKG(0)[("~"_PXIPKG_"~") D
.. K ^TMP("PXICLN9")
.. ;
.. ;Copy visit
.. S PXINODE=""
.. F S PXINODE=$O(^AUPNVSIT(PXIVSIT,PXINODE)) Q:PXINODE="" D
... S ^TMP("PXICLN9","VST",1,PXINODE,"AFTER")=^AUPNVSIT(PXIVSIT,PXINODE)
... S ^TMP("PXICLN9","VST",1,PXINODE,"BEFORE")=""
.. S ^TMP("PXICLN9","VST",1,"IEN")=""
.. ;Set sum stuff need by PXK
.. S $P(^TMP("PXICLN9","VST",1,150,"AFTER"),"^",3)="A"
.. S $P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",8)=""
.. S ^TMP("PXICLN9","PKG")=PXIPKG
.. ;
.. ;Rad?
.. I PXIPKG(1)=PXIPKG D
... S ^TMP("PXICLN9","SOR")=PXISOR(1)
... S $P(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)=PXISOR(1)
... S PXISOR=PXISOR(1)
... S PXIHLOC=$P($$RADLOC($P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",5),$P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",1)),"^",2)
.. ;Lab?
.. E D
... S ^TMP("PXICLN9","SOR")=PXISOR(2)
... S $P(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)=PXISOR(2)
... S PXISOR=PXISOR(2)
... S PXIHLOC=PXIHLOC(2)
.. ;
.. ;check if the hospital location was ok if it is see if visit needs
.. ;edit and quit
.. I PXIHLOC>0,$P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",22)=PXIHLOC D Q
... K VSIT
... I $P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",7)'="X" S VSIT("SVC")="X"
... I $P(^TMP("PXICLN9","VST",1,150,"AFTER"),"^",3)'="A" S VSIT("PRI")="A"
... I $P(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)'=PXISOR S VSIT("SOR")=PXISOR
... Q:'$D(VSIT)
... S VSIT("IEN")=PXIVSIT
... D UPD^VSIT
.. ;
.. S:PXIHLOC>0 $P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",22)=PXIHLOC
.. ;
.. ;Copy v-files pointing to visit
.. ; (do not care about the stop code visit will just delete them)
.. F PXIFILE="CPT","IMM","PED","POV","PRV","SK","TRT","HF","XAM" D
... S PXIVFILE="^AUPNV"_PXIFILE
... S PXIVIEN=0
... F PXICNT=1:1 S PXIVIEN=$O(@PXIVFILE@("AD",PXIVSIT,PXIVIEN)) Q:'PXIVIEN D
.... ;
.... ;If this is Lab and is a even numbered duplicate CPT then do not save it
.... I PXIFILE="CPT",PXIPKG(2)=PXIPKG D Q:PXITDUP=1
..... ;check set
..... S PXITDUP=0
..... S PXITCNT=""
..... F S PXITCNT=$O(^TMP("PXICLN9","CPT",PXITCNT)) Q:'PXITCNT D Q:PXITDUP
...... S PXITNODE=""
...... F S PXITNODE=$O(^TMP("PXICLN9","CPT",PXITCNT,PXITNODE)) Q:PXITNODE'=+PXITNODE D Q:PXITDUP=-1
....... I $P(^TMP("PXICLN9","CPT",PXITCNT,PXITNODE,"AFTER"),"^",1,15)=$P($G(^AUPNVCPT(PXIVIEN,PXITNODE)),"^",1,15) S PXITDUP=1
....... E S PXITDUP=-1
..... I PXITDUP=1 D
...... S PXDUPCPT(PXITCNT)=$G(PXDUPCPT(PXITCNT))+1
...... I '(PXDUPCPT(PXITCNT)#2) S $P(^TMP("PXICLN9","CPT",PXITCNT,0,"AFTER"),"^",16)=$P(^TMP("PXICLN9","CPT",PXITCNT,0,"AFTER"),"^",16)+$P($G(^AUPNVCPT(PXIVIEN,0)),"^",16)
.... ;
.... ;Copy a v-file entry
.... S PXINODE=""
.... F S PXINODE=$O(@PXIVFILE@(PXIVIEN,PXINODE)) Q:PXINODE="" D:PXINODE'=801
..... S ^TMP("PXICLN9",PXIFILE,PXICNT,PXINODE,"AFTER")=@PXIVFILE@(PXIVIEN,PXINODE)
..... S ^TMP("PXICLN9",PXIFILE,PXICNT,PXINODE,"BEFORE")=""
.... S ^TMP("PXICLN9",PXIFILE,PXICNT,"IEN")=""
.... ;
.... ;Now fix any fields
.... S:$P($G(^TMP("PXICLN9",PXIFILE,PXICNT,812,"AFTER")),"^",3)="" $P(^TMP("PXICLN9",PXIFILE,PXICNT,812,"AFTER"),"^",3)=PXISOR
.. ;
.. ;Process
.. ;
.. ;delete old data
.. S PXIDEL=$$DELVFILE^PXAPIDEL("ALL",PXIVSIT,"","","","","")
.. ;
.. ;save data
.. K ^TMP("PXK",$J)
.. M ^TMP("PXK",$J)=^TMP("PXICLN9")
.. K ^TMP("PXICLN9")
.. D EN1^PXKMAIN
.. S PXINVSIT=^TMP("PXK",$J,"VST",1,"IEN")
.. ;fix 801 nodes? no they are ok
.. D EVENT^PXKMAIN
.. ;
.. ;if the new visit is the same visit as the old visit then done
.. Q:PXIVSIT=PXINVSIT
.. ;
.. ;if there is a new visit then assume all worked
.. I PXINVSIT>0 D
... ;
... ;fix pointers from Rad and IB
... N PXIRA,PXIIBT,PXIFDA,PXIDIERR
... S (PXIRA(1),PXIIBT)=0
... F S PXIRA(1)=$O(^RADPT("AVSIT",PXIVSIT,PXIRA(1))) Q:'PXIRA(1) D
.... S PXIRA(2)=0
.... F S PXIRA(2)=$O(^RADPT("AVSIT",PXIVSIT,PXIRA(1),PXIRA(2))) Q:'PXIRA(2) D
..... S PXIRA(3)=0
..... F S PXIRA(3)=$O(^RADPT("AVSIT",PXIVSIT,PXIRA(1),PXIRA(2),PXIRA(3))) Q:'PXIRA(3) D
...... I PXIRA(1)>0,PXIRA(2)>0,PXIRA(3)>0 D
....... S PXIRA=PXIRA(3)_","_PXIRA(2)_","_PXIRA(1)_","
....... S PXIFDA(70.03,PXIRA,27)=PXINVSIT
... F S PXIIBT=$O(^IBT(356,"AVSIT",PXIVSIT,PXIIBT)) Q:'PXIIBT D
.... I PXIIBT>0 D
..... S PXIIBT=PXIIBT_","
..... S PXIFDA(356,PXIIBT,.03)=PXINVSIT
... I $D(PXIFDA) D FILE^DIE("","PXIFDA","PXIDIERR")
.. ;
.. ;if the visit was not deleted try again
.. I PXIDEL<1 D
... ;make sure that there are no extra Outpatient Encounter entries
... S PXIOE=0
... F S PXIOE=$O(^SCE("AVSIT",PXIVSIT,PXIOE)) Q:'PXIOE D EN^SDCODEL(PXIOE,0)
... S PXIDEL=$$KILL^VSITKIL(PXIVSIT)
... I PXIDEL>0 D
.... ;change it to a stop visit
.... K VSIT
.... S VSIT("PRI")="S"
.... S VSIT("IEN")=PXIVSIT
.... D UPD^VSIT
.... ;there was some problem deleting this one save it
.... S ^XTMP("PXICLN9",$J,PXIVST)=PXIDEL
. ;
. ;Check the encounter type
. I $P($G(^AUPNVSIT(PXIVSIT,150)),"^",3)="O" D
.. Q:$D(^VSIT(150.1,"B",+$P($G(^DIC(40.7,+$P($G(^AUPNVSIT(PXIVSIT,0)),"^",8),0)),"^",2)))
.. ;If it is "O" and it should not be, change it to "P"
.. K VSIT
.. I $P($G(^AUPNVSIT(PXIVSIT,812)),"^",3)="" D
... I PXICPT,$P($G(^AUPNVCPT(PXICPT,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVCPT(PXICPT,812)),"^",3)
... E I PXIPRV,$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)
.. S VSIT("PRI")="P"
.. S VSIT("SVC")="A"
.. I +$$IP^VSITCK1(+$G(^AUPNVSIT(PXIVSIT,0)),$P($G(^AUPNVSIT(PXIVSIT,0)),"^",5)) S VSIT("SVC")="I"
.. S VSIT("IEN")=PXIVSIT
.. D UPD^VSIT
. ;
. E I $P($G(^AUPNVSIT(PXIVSIT,150)),"^",3)="P" D
.. Q:'$D(^VSIT(150.1,"B",+$P($G(^DIC(40.7,+$P($G(^AUPNVSIT(PXIVSIT,0)),"^",8),0)),"^",2)))
.. ;If it is "P" and it should not be, change it to "O"
.. K VSIT
.. I $P($G(^AUPNVSIT(PXIVSIT,812)),"^",3)="" D
... I PXICPT,$P($G(^AUPNVCPT(PXICPT,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVCPT(PXICPT,812)),"^",3)
... E I PXIPRV,$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)
.. S VSIT("PRI")="O"
.. S VSIT("SVC")="X"
.. I +$$IP^VSITCK1(+$G(^AUPNVSIT(PXIVSIT,0)),$P($G(^AUPNVSIT(PXIVSIT,0)),"^",5)) S VSIT("SVC")="D"
.. S VSIT("IEN")=PXIVSIT
.. D UPD^VSIT
. S $P(^PX(815,1,"PATCH"),"^",1)=PXIVSIT
K ^TMP("PXICLN9"),^TMP("PXK",$J)
Q
;
RADNUC ;CAH/HIRMFO;for PCE data clean-up ;10/7/96 09:42
;
RADLOC(DFN,PXRADT) ;Returns Hosp Loc of Rad/Nuc Med exam
;Input:
; DFN = Patient file #2 internal entry number
; PXRADT = Rad exam dt/time in internal FileMan format
; Sample input: (6552,2961015.0915)
;Output:
; If successful -
; Imaging Loc name ^ pointer to file 44
; Sample output: X-RAY AREA B^35
;
; If unsuccessful (exam or Imaging loc missing, or file 44
; entry deleted, or patient does not exist in Rad/NM Patient
; file #70) - 0
;
N X,PXRA0,PXRADTI,PXRALOC,PXRALOC1,PXRALOC2
I 'DFN Q 0
I 'PXRADT Q 0
I '$D(^RADPT(DFN)) Q 0 ;patient doesn't exist in file #70
S PXRADTI=9999999.9999-PXRADT ;Convert exam dt/t to subfile ien
S PXRA0=$G(^RADPT(DFN,"DT",PXRADTI,0)) I '$L(PXRA0) Q 0 ;if no such rad/nuc med visit, fail
S PXRALOC=$P(PXRA0,"^",4) I 'PXRALOC Q 0 ;if no imaging loc, fail
S PXRALOC1=$P(^RA(79.1,+PXRALOC,0),"^",1) I 'PXRALOC1 Q 0 ;if dangling pointer - file 44 entry deleted? fail
I '$D(^SC(PXRALOC1)) Q 0 ;File 44 entry deleted? fail
S PXRALOC2=$P($G(^SC(PXRALOC1,0)),"^",1)
Q PXRALOC2_"^"_PXRALOC1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXICLN9B 9020 printed Apr 09, 2024@21:27:50 Page 2
PXICLN9B ;ISL/dee - Cleanup routine for PX*1.0*9 ;11/8/96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**9**;Aug 12, 1996
+2 ;
CLEANUP ;
+1 ;Flag that this job is running.
NEW PXICLN9
SET PXICLN9=1
+2 NEW PXIVSIT,PXIVDT,PXICPT,PXIFILE,PXIVFILE,PXIVIEN,PXICNT
+3 NEW PXINODE,VSIT,PXINVSIT,PXITVSIT,PXIDEL
+4 NEW PXITDUP,PXITCNT,PXITNODE
+5 NEW PXISOR,PXIPKG,PXIHLOC,PXIOE
+6 ;
+7 ;Set up package and source for Rad and Lab
+8 SET PXISOR(1)=$$SOURCE^PXAPIUTL("RAD/NUC MED")
+9 SET PXISOR(2)=$$SOURCE^PXAPIUTL("LAB DATA")
+10 SET PXIPKG(1)=$$PKG2IEN^VSIT("RA")
+11 SET PXIPKG(2)=$$PKG2IEN^VSIT("LR")
+12 SET PXIPKG(0)="~"_PXIPKG(1)_"~"_PXIPKG(2)_"~"
+13 ;
+14 ;get clinic for lab data
+15 SET PXIHLOC(2)=+$GET(^LAB(69.9,1,.8))
+16 ;
+17 IF $DATA(^TMP("PXICLN9"))
Begin DoDot:1
+18 ;save data from where tasked errored out
+19 KILL ^TMP("PXK",$JOB)
+20 MERGE ^TMP("PXK",$JOB)=^TMP("PXICLN9")
+21 KILL ^TMP("PXICLN9")
+22 DO EN1^PXKMAIN
+23 KILL ^TMP("PXK",$JOB)
+24 DO EVENT^PXKMAIN
End DoDot:1
+25 ;
+26 ;Where to start?
+27 SET PXIVSIT=+$GET(^PX(815,1,"PATCH"))
+28 IF PXIVSIT<1
Begin DoDot:1
+29 SET PXIVSIT=$ORDER(^AUPNVSIT("A"),-1)
+30 IF PXIVSIT>0
SET PXIVSIT=PXIVSIT+1
+31 IF '$TEST
SET PXIVSIT=0
+32 SET $PIECE(^PX(815,1,"PATCH"),"^",1)=PXIVSIT
End DoDot:1
+33 ;
+34 ;*R "Visit ien: ",PXIVSIT ;*
+35 ;*D ;*
+36 FOR
SET PXIVSIT=$ORDER(^AUPNVSIT(PXIVSIT),-1)
if 'PXIVSIT
QUIT
Begin DoDot:1
+37 SET PXICPT=$ORDER(^AUPNVCPT("AD",PXIVSIT,0))
+38 SET PXIPRV=$ORDER(^AUPNVPRV("AD",PXIVSIT,0))
+39 IF PXICPT
SET PXIPKG=$PIECE($GET(^AUPNVCPT(+PXICPT,812)),"^",2)
+40 IF '$TEST
SET PXIPKG=$PIECE($GET(^AUPNVPRV(+PXIPRV,812)),"^",2)
+41 ;
+42 ;Rad or Lab ?
+43 IF (PXICPT!PXIPRV)
IF PXIPKG(0)[("~"_PXIPKG_"~")
Begin DoDot:2
+44 KILL ^TMP("PXICLN9")
+45 ;
+46 ;Copy visit
+47 SET PXINODE=""
+48 FOR
SET PXINODE=$ORDER(^AUPNVSIT(PXIVSIT,PXINODE))
if PXINODE=""
QUIT
Begin DoDot:3
+49 SET ^TMP("PXICLN9","VST",1,PXINODE,"AFTER")=^AUPNVSIT(PXIVSIT,PXINODE)
+50 SET ^TMP("PXICLN9","VST",1,PXINODE,"BEFORE")=""
End DoDot:3
+51 SET ^TMP("PXICLN9","VST",1,"IEN")=""
+52 ;Set sum stuff need by PXK
+53 SET $PIECE(^TMP("PXICLN9","VST",1,150,"AFTER"),"^",3)="A"
+54 SET $PIECE(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",8)=""
+55 SET ^TMP("PXICLN9","PKG")=PXIPKG
+56 ;
+57 ;Rad?
+58 IF PXIPKG(1)=PXIPKG
Begin DoDot:3
+59 SET ^TMP("PXICLN9","SOR")=PXISOR(1)
+60 SET $PIECE(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)=PXISOR(1)
+61 SET PXISOR=PXISOR(1)
+62 SET PXIHLOC=$PIECE($$RADLOC($PIECE(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",5),$PIECE(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",1)),"^",2)
End DoDot:3
+63 ;Lab?
+64 IF '$TEST
Begin DoDot:3
+65 SET ^TMP("PXICLN9","SOR")=PXISOR(2)
+66 SET $PIECE(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)=PXISOR(2)
+67 SET PXISOR=PXISOR(2)
+68 SET PXIHLOC=PXIHLOC(2)
End DoDot:3
+69 ;
+70 ;check if the hospital location was ok if it is see if visit needs
+71 ;edit and quit
+72 IF PXIHLOC>0
IF $PIECE(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",22)=PXIHLOC
Begin DoDot:3
+73 KILL VSIT
+74 IF $PIECE(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",7)'="X"
SET VSIT("SVC")="X"
+75 IF $PIECE(^TMP("PXICLN9","VST",1,150,"AFTER"),"^",3)'="A"
SET VSIT("PRI")="A"
+76 IF $PIECE(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)'=PXISOR
SET VSIT("SOR")=PXISOR
+77 if '$DATA(VSIT)
QUIT
+78 SET VSIT("IEN")=PXIVSIT
+79 DO UPD^VSIT
End DoDot:3
QUIT
+80 ;
+81 if PXIHLOC>0
SET $PIECE(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",22)=PXIHLOC
+82 ;
+83 ;Copy v-files pointing to visit
+84 ; (do not care about the stop code visit will just delete them)
+85 FOR PXIFILE="CPT","IMM","PED","POV","PRV","SK","TRT","HF","XAM"
Begin DoDot:3
+86 SET PXIVFILE="^AUPNV"_PXIFILE
+87 SET PXIVIEN=0
+88 FOR PXICNT=1:1
SET PXIVIEN=$ORDER(@PXIVFILE@("AD",PXIVSIT,PXIVIEN))
if 'PXIVIEN
QUIT
Begin DoDot:4
+89 ;
+90 ;If this is Lab and is a even numbered duplicate CPT then do not save it
+91 IF PXIFILE="CPT"
IF PXIPKG(2)=PXIPKG
Begin DoDot:5
+92 ;check set
+93 SET PXITDUP=0
+94 SET PXITCNT=""
+95 FOR
SET PXITCNT=$ORDER(^TMP("PXICLN9","CPT",PXITCNT))
if 'PXITCNT
QUIT
Begin DoDot:6
+96 SET PXITNODE=""
+97 FOR
SET PXITNODE=$ORDER(^TMP("PXICLN9","CPT",PXITCNT,PXITNODE))
if PXITNODE'=+PXITNODE
QUIT
Begin DoDot:7
+98 IF $PIECE(^TMP("PXICLN9","CPT",PXITCNT,PXITNODE,"AFTER"),"^",1,15)=$PIECE($GET(^AUPNVCPT(PXIVIEN,PXITNODE)),"^",1,15)
SET PXITDUP=1
+99 IF '$TEST
SET PXITDUP=-1
End DoDot:7
if PXITDUP=-1
QUIT
End DoDot:6
if PXITDUP
QUIT
+100 IF PXITDUP=1
Begin DoDot:6
+101 SET PXDUPCPT(PXITCNT)=$GET(PXDUPCPT(PXITCNT))+1
+102 IF '(PXDUPCPT(PXITCNT)#2)
SET $PIECE(^TMP("PXICLN9","CPT",PXITCNT,0,"AFTER"),"^",16)=$PIECE(^TMP("PXICLN9","CPT",PXITCNT,0,"AFTER"),"^",16)+$PIECE($GET(^AUPNVCPT(PXIVIEN,0)),"^",16)
End DoDot:6
End DoDot:5
if PXITDUP=1
QUIT
+103 ;
+104 ;Copy a v-file entry
+105 SET PXINODE=""
+106 FOR
SET PXINODE=$ORDER(@PXIVFILE@(PXIVIEN,PXINODE))
if PXINODE=""
QUIT
if PXINODE'=801
Begin DoDot:5
+107 SET ^TMP("PXICLN9",PXIFILE,PXICNT,PXINODE,"AFTER")=@PXIVFILE@(PXIVIEN,PXINODE)
+108 SET ^TMP("PXICLN9",PXIFILE,PXICNT,PXINODE,"BEFORE")=""
End DoDot:5
+109 SET ^TMP("PXICLN9",PXIFILE,PXICNT,"IEN")=""
+110 ;
+111 ;Now fix any fields
+112 if $PIECE($GET(^TMP("PXICLN9",PXIFILE,PXICNT,812,"AFTER")),"^",3)=""
SET $PIECE(^TMP("PXICLN9",PXIFILE,PXICNT,812,"AFTER"),"^",3)=PXISOR
End DoDot:4
End DoDot:3
+113 ;
+114 ;Process
+115 ;
+116 ;delete old data
+117 SET PXIDEL=$$DELVFILE^PXAPIDEL("ALL",PXIVSIT,"","","","","")
+118 ;
+119 ;save data
+120 KILL ^TMP("PXK",$JOB)
+121 MERGE ^TMP("PXK",$JOB)=^TMP("PXICLN9")
+122 KILL ^TMP("PXICLN9")
+123 DO EN1^PXKMAIN
+124 SET PXINVSIT=^TMP("PXK",$JOB,"VST",1,"IEN")
+125 ;fix 801 nodes? no they are ok
+126 DO EVENT^PXKMAIN
+127 ;
+128 ;if the new visit is the same visit as the old visit then done
+129 if PXIVSIT=PXINVSIT
QUIT
+130 ;
+131 ;if there is a new visit then assume all worked
+132 IF PXINVSIT>0
Begin DoDot:3
+133 ;
+134 ;fix pointers from Rad and IB
+135 NEW PXIRA,PXIIBT,PXIFDA,PXIDIERR
+136 SET (PXIRA(1),PXIIBT)=0
+137 FOR
SET PXIRA(1)=$ORDER(^RADPT("AVSIT",PXIVSIT,PXIRA(1)))
if 'PXIRA(1)
QUIT
Begin DoDot:4
+138 SET PXIRA(2)=0
+139 FOR
SET PXIRA(2)=$ORDER(^RADPT("AVSIT",PXIVSIT,PXIRA(1),PXIRA(2)))
if 'PXIRA(2)
QUIT
Begin DoDot:5
+140 SET PXIRA(3)=0
+141 FOR
SET PXIRA(3)=$ORDER(^RADPT("AVSIT",PXIVSIT,PXIRA(1),PXIRA(2),PXIRA(3)))
if 'PXIRA(3)
QUIT
Begin DoDot:6
+142 IF PXIRA(1)>0
IF PXIRA(2)>0
IF PXIRA(3)>0
Begin DoDot:7
+143 SET PXIRA=PXIRA(3)_","_PXIRA(2)_","_PXIRA(1)_","
+144 SET PXIFDA(70.03,PXIRA,27)=PXINVSIT
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
+145 FOR
SET PXIIBT=$ORDER(^IBT(356,"AVSIT",PXIVSIT,PXIIBT))
if 'PXIIBT
QUIT
Begin DoDot:4
+146 IF PXIIBT>0
Begin DoDot:5
+147 SET PXIIBT=PXIIBT_","
+148 SET PXIFDA(356,PXIIBT,.03)=PXINVSIT
End DoDot:5
End DoDot:4
+149 IF $DATA(PXIFDA)
DO FILE^DIE("","PXIFDA","PXIDIERR")
End DoDot:3
+150 ;
+151 ;if the visit was not deleted try again
+152 IF PXIDEL<1
Begin DoDot:3
+153 ;make sure that there are no extra Outpatient Encounter entries
+154 SET PXIOE=0
+155 FOR
SET PXIOE=$ORDER(^SCE("AVSIT",PXIVSIT,PXIOE))
if 'PXIOE
QUIT
DO EN^SDCODEL(PXIOE,0)
+156 SET PXIDEL=$$KILL^VSITKIL(PXIVSIT)
+157 IF PXIDEL>0
Begin DoDot:4
+158 ;change it to a stop visit
+159 KILL VSIT
+160 SET VSIT("PRI")="S"
+161 SET VSIT("IEN")=PXIVSIT
+162 DO UPD^VSIT
+163 ;there was some problem deleting this one save it
+164 SET ^XTMP("PXICLN9",$JOB,PXIVST)=PXIDEL
End DoDot:4
End DoDot:3
End DoDot:2
+165 ;
+166 ;Check the encounter type
+167 IF $PIECE($GET(^AUPNVSIT(PXIVSIT,150)),"^",3)="O"
Begin DoDot:2
+168 if $DATA(^VSIT(150.1,"B",+$PIECE($GET(^DIC(40.7,+$PIECE($GET(^AUPNVSIT(PXIVSIT,0)),"^",8),0)),"^",2)))
QUIT
+169 ;If it is "O" and it should not be, change it to "P"
+170 KILL VSIT
+171 IF $PIECE($GET(^AUPNVSIT(PXIVSIT,812)),"^",3)=""
Begin DoDot:3
+172 IF PXICPT
IF $PIECE($GET(^AUPNVCPT(PXICPT,812)),"^",3)]""
SET VSIT("SOR")=$PIECE($GET(^AUPNVCPT(PXICPT,812)),"^",3)
+173 IF '$TEST
IF PXIPRV
IF $PIECE($GET(^AUPNVPRV(PXIPRV,812)),"^",3)]""
SET VSIT("SOR")=$PIECE($GET(^AUPNVPRV(PXIPRV,812)),"^",3)
End DoDot:3
+174 SET VSIT("PRI")="P"
+175 SET VSIT("SVC")="A"
+176 IF +$$IP^VSITCK1(+$GET(^AUPNVSIT(PXIVSIT,0)),$PIECE($GET(^AUPNVSIT(PXIVSIT,0)),"^",5))
SET VSIT("SVC")="I"
+177 SET VSIT("IEN")=PXIVSIT
+178 DO UPD^VSIT
End DoDot:2
+179 ;
+180 IF '$TEST
IF $PIECE($GET(^AUPNVSIT(PXIVSIT,150)),"^",3)="P"
Begin DoDot:2
+181 if '$DATA(^VSIT(150.1,"B",+$PIECE($GET(^DIC(40.7,+$PIECE($GET(^AUPNVSIT(PXIVSIT,0)),"^",8),0)),"^",2)))
QUIT
+182 ;If it is "P" and it should not be, change it to "O"
+183 KILL VSIT
+184 IF $PIECE($GET(^AUPNVSIT(PXIVSIT,812)),"^",3)=""
Begin DoDot:3
+185 IF PXICPT
IF $PIECE($GET(^AUPNVCPT(PXICPT,812)),"^",3)]""
SET VSIT("SOR")=$PIECE($GET(^AUPNVCPT(PXICPT,812)),"^",3)
+186 IF '$TEST
IF PXIPRV
IF $PIECE($GET(^AUPNVPRV(PXIPRV,812)),"^",3)]""
SET VSIT("SOR")=$PIECE($GET(^AUPNVPRV(PXIPRV,812)),"^",3)
End DoDot:3
+187 SET VSIT("PRI")="O"
+188 SET VSIT("SVC")="X"
+189 IF +$$IP^VSITCK1(+$GET(^AUPNVSIT(PXIVSIT,0)),$PIECE($GET(^AUPNVSIT(PXIVSIT,0)),"^",5))
SET VSIT("SVC")="D"
+190 SET VSIT("IEN")=PXIVSIT
+191 DO UPD^VSIT
End DoDot:2
+192 SET $PIECE(^PX(815,1,"PATCH"),"^",1)=PXIVSIT
End DoDot:1
+193 KILL ^TMP("PXICLN9"),^TMP("PXK",$JOB)
+194 QUIT
+195 ;
RADNUC ;CAH/HIRMFO;for PCE data clean-up ;10/7/96 09:42
+1 ;
RADLOC(DFN,PXRADT) ;Returns Hosp Loc of Rad/Nuc Med exam
+1 ;Input:
+2 ; DFN = Patient file #2 internal entry number
+3 ; PXRADT = Rad exam dt/time in internal FileMan format
+4 ; Sample input: (6552,2961015.0915)
+5 ;Output:
+6 ; If successful -
+7 ; Imaging Loc name ^ pointer to file 44
+8 ; Sample output: X-RAY AREA B^35
+9 ;
+10 ; If unsuccessful (exam or Imaging loc missing, or file 44
+11 ; entry deleted, or patient does not exist in Rad/NM Patient
+12 ; file #70) - 0
+13 ;
+14 NEW X,PXRA0,PXRADTI,PXRALOC,PXRALOC1,PXRALOC2
+15 IF 'DFN
QUIT 0
+16 IF 'PXRADT
QUIT 0
+17 ;patient doesn't exist in file #70
IF '$DATA(^RADPT(DFN))
QUIT 0
+18 ;Convert exam dt/t to subfile ien
SET PXRADTI=9999999.9999-PXRADT
+19 ;if no such rad/nuc med visit, fail
SET PXRA0=$GET(^RADPT(DFN,"DT",PXRADTI,0))
IF '$LENGTH(PXRA0)
QUIT 0
+20 ;if no imaging loc, fail
SET PXRALOC=$PIECE(PXRA0,"^",4)
IF 'PXRALOC
QUIT 0
+21 ;if dangling pointer - file 44 entry deleted? fail
SET PXRALOC1=$PIECE(^RA(79.1,+PXRALOC,0),"^",1)
IF 'PXRALOC1
QUIT 0
+22 ;File 44 entry deleted? fail
IF '$DATA(^SC(PXRALOC1))
QUIT 0
+23 SET PXRALOC2=$PIECE($GET(^SC(PXRALOC1,0)),"^",1)
+24 QUIT PXRALOC2_"^"_PXRALOC1
+25 ;
