BDGPOST4 ; IHS/ANMC/LJF - PIMS POST INIT (IC FILES) ; [ 04/17/2003 4:28 PM ]
;;5.3;PIMS;;APR 26, 2002
;
;
IC ;EP; copy data from 2 incomplete chart files to new one
; copy ^ADGIC & ^ADGDSI -> ^BDGIC
; data left in old files until future patch
;
; copy incomplete chart file first
Q:$O(^BDGIC(0)) ;already has data
D BMES^XPDUTL("Copying Incomplete Chart entries to new file...")
;
NEW OLD,OLD1,OLD2,OLD3,NEW,NEW2,I,DATA,DIK,X,V
S OLD=0 F S OLD=$O(^ADGIC(OLD)) Q:'OLD D
. Q:$G(^ADGIC(OLD,0))="" ;bad entry
. S DFN=+$G(^ADGIC(OLD,0))
. ;
. ; add new entry
. S OLD1=0 F S OLD1=$O(^ADGIC(OLD,"D",OLD1)) Q:'OLD1 D
.. S DATA=$G(^ADGIC(OLD,"D",OLD1,0)) Q:DATA=""
.. S NEW=$G(NEW)+1,^BDGIC(NEW,0)=DFN_U_(+DATA)
.. S $P(^BDGIC(0),U,3)=NEW,$P(^BDGIC(0),U,4)=$P(^BDGIC(0),U,4)+1
.. ;
.. ; try to find PCC visit based on discharge and patient
.. S X=$O(^DGPM("AMV3",+DATA,DFN,0)) I X D
... S X=$P($G(^DGPM(X,0)),U,14) ;admission linked to discharge
... S V=$P($G(^DGPM(X,0)),U,27) I V S $P(^BDGIC(NEW,0),U,3)=V
.. ;
.. ; now copy data items to new location
.. F I="1;2","4;4","12;18","14;12","15;13" D
... S $P(^BDGIC(NEW,0),U,$P(I,";",2))=$P(DATA,U,+I)
.. ;
.. ; copy provider multiples
.. S NEW2=1 ;start over for each patient
.. Q:'$D(^ADGIC(OLD,"D",OLD1,"P",0)) ;no provider entries to copy
.. S ^BDGIC(NEW,1,0)="^9009016.11P^"_$P(^ADGIC(OLD,"D",OLD1,"P",0),U,3,4)
.. ;
.. S OLD2=0 F S OLD2=$O(^ADGIC(OLD,"D",OLD1,"P",OLD2)) Q:'OLD2 D
... Q:$G(^ADGIC(OLD,"D",OLD1,"P",OLD2,0))="" ;bad entry
... ;
... ; now get chart deficiencies
... S OLD3=0
... F S OLD3=$O(^ADGIC(OLD,"D",OLD1,"P",OLD2,"C",OLD3)) Q:'OLD3 D
.... S DATA=$G(^ADGIC(OLD,"D",OLD1,"P",OLD2,"C",OLD3,0)) Q:DATA=""
.... S ^BDGIC(NEW,1,NEW2,0)=^ADGIC(OLD,"D",OLD1,"P",OLD2,0)
.... S $P(^BDGIC(NEW,1,NEW2,0),U,2)=+DATA
.... S NEW2=NEW2+1
;IHS/ITSC/WAR 4/17/03 P63 Added next line per Linda
K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
;
;
; now copy from day surgery incomplete file
D BMES^XPDUTL("Copying DS Incomplete Chart entries to new file...")
;
S OLD=0 F S OLD=$O(^ADGDSI(OLD)) Q:'OLD D
. Q:$G(^ADGDSI(OLD,0))="" ;bad entry
. S DFN=+$G(^ADGDSI(OLD,0))
. ;
. ; add new entry
. S OLD1=0 F S OLD1=$O(^ADGDSI(OLD,"DT",OLD1)) Q:'OLD1 D
.. S DATA=$G(^ADGDSI(OLD,"DT",OLD1,0)) Q:DATA=""
.. S NEW=$G(NEW)+1,^BDGIC(NEW,0)=DFN_"^^^^"_(+DATA) ;surg date
.. S $P(^BDGIC(0),U,3)=NEW,$P(^BDGIC(0),U,4)=$P(^BDGIC(0),U,4)+1
.. ;
.. ; try to find PCC visit based on surgery date and patient
.. S X=$O(^SRF("AIHS4",((+DATA)\1),DFN,0)) I X D
... S V=$P($G(^SRF(X,9999999)),U) I V S $P(^BDGIC(NEW,0),U,3)=V
.. ;
.. ; now copy data items to new location
.. F I="5;4","4;18" D
... S $P(^BDGIC(NEW,0),U,$P(I,";",2))=$P(DATA,U,+I)
.. ;
.. ; copy provider multiples
.. S NEW2=1 ;start over for each patient
.. Q:'$D(^ADGDSI(OLD,"DT",OLD1,"P",0)) ;no provider entries to copy
.. S ^BDGIC(NEW,1,0)="^9009016.11P^"_$P(^ADGDSI(OLD,"DT",OLD1,"P",0),U,3,4)
.. ;
.. S OLD2=0 F S OLD2=$O(^ADGDSI(OLD,"DT",OLD1,"P",OLD2)) Q:'OLD2 D
... Q:$G(^ADGDSI(OLD,"DT",OLD1,"P",OLD2,0))="" ;bad entry
... ;
... ; now get chart deficiencies
... S OLD3=0
... F S OLD3=$O(^ADGDSI(OLD,"DT",OLD1,"P",OLD2,"CD",OLD3)) Q:'OLD3 D
.... S DATA=$G(^ADGDSI(OLD,"DT",OLD1,"P",OLD2,"CD",OLD3,0)) Q:DATA=""
.... S ^BDGIC(NEW,1,NEW2,0)=^ADGDSI(OLD,"DT",OLD1,"P",OLD2,0)
.... S $P(^BDGIC(NEW,1,NEW2,0),U,2)=+DATA
.... S NEW2=NEW2+1
;
;
; now index new file
S DIK="^BDGIC(" D IXALL^DIK
K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
Q
BDGPOST4 ; IHS/ANMC/LJF - PIMS POST INIT (IC FILES) ; [ 04/17/2003 4:28 PM ]
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 ;
IC ;EP; copy data from 2 incomplete chart files to new one
+1 ; copy ^ADGIC & ^ADGDSI -> ^BDGIC
+2 ; data left in old files until future patch
+3 ;
+4 ; copy incomplete chart file first
+5 ;already has data
IF $ORDER(^BDGIC(0))
QUIT
+6 DO BMES^XPDUTL("Copying Incomplete Chart entries to new file...")
+7 ;
+8 NEW OLD,OLD1,OLD2,OLD3,NEW,NEW2,I,DATA,DIK,X,V
+9 SET OLD=0
FOR
SET OLD=$ORDER(^ADGIC(OLD))
IF 'OLD
QUIT
Begin DoDot:1
+10 ;bad entry
IF $GET(^ADGIC(OLD,0))=""
QUIT
+11 SET DFN=+$GET(^ADGIC(OLD,0))
+12 ;
+13 ; add new entry
+14 SET OLD1=0
FOR
SET OLD1=$ORDER(^ADGIC(OLD,"D",OLD1))
IF 'OLD1
QUIT
Begin DoDot:2
+15 SET DATA=$GET(^ADGIC(OLD,"D",OLD1,0))
IF DATA=""
QUIT
+16 SET NEW=$GET(NEW)+1
SET ^BDGIC(NEW,0)=DFN_U_(+DATA)
+17 SET $PIECE(^BDGIC(0),U,3)=NEW
SET $PIECE(^BDGIC(0),U,4)=$PIECE(^BDGIC(0),U,4)+1
+18 ;
+19 ; try to find PCC visit based on discharge and patient
+20 SET X=$ORDER(^DGPM("AMV3",+DATA,DFN,0))
IF X
Begin DoDot:3
+21 ;admission linked to discharge
SET X=$PIECE($GET(^DGPM(X,0)),U,14)
+22 SET V=$PIECE($GET(^DGPM(X,0)),U,27)
IF V
SET $PIECE(^BDGIC(NEW,0),U,3)=V
End DoDot:3
+23 ;
+24 ; now copy data items to new location
+25 FOR I="1;2","4;4","12;18","14;12","15;13"
Begin DoDot:3
+26 SET $PIECE(^BDGIC(NEW,0),U,$PIECE(I,";",2))=$PIECE(DATA,U,+I)
End DoDot:3
+27 ;
+28 ; copy provider multiples
+29 ;start over for each patient
SET NEW2=1
+30 ;no provider entries to copy
IF '$DATA(^ADGIC(OLD,"D",OLD1,"P",0))
QUIT
+31 SET ^BDGIC(NEW,1,0)="^9009016.11P^"_$PIECE(^ADGIC(OLD,"D",OLD1,"P",0),U,3,4)
+32 ;
+33 SET OLD2=0
FOR
SET OLD2=$ORDER(^ADGIC(OLD,"D",OLD1,"P",OLD2))
IF 'OLD2
QUIT
Begin DoDot:3
+34 ;bad entry
IF $GET(^ADGIC(OLD,"D",OLD1,"P",OLD2,0))=""
QUIT
+35 ;
+36 ; now get chart deficiencies
+37 SET OLD3=0
+38 FOR
SET OLD3=$ORDER(^ADGIC(OLD,"D",OLD1,"P",OLD2,"C",OLD3))
IF 'OLD3
QUIT
Begin DoDot:4
+39 SET DATA=$GET(^ADGIC(OLD,"D",OLD1,"P",OLD2,"C",OLD3,0))
IF DATA=""
QUIT
+40 SET ^BDGIC(NEW,1,NEW2,0)=^ADGIC(OLD,"D",OLD1,"P",OLD2,0)
+41 SET $PIECE(^BDGIC(NEW,1,NEW2,0),U,2)=+DATA
+42 SET NEW2=NEW2+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;IHS/ITSC/WAR 4/17/03 P63 Added next line per Linda
+44 KILL X
SET X=$$REPEAT^XLFSTR(" ",20)_"Done."
DO MES^XPDUTL(.X)
+45 ;
+46 ;
+47 ; now copy from day surgery incomplete file
+48 DO BMES^XPDUTL("Copying DS Incomplete Chart entries to new file...")
+49 ;
+50 SET OLD=0
FOR
SET OLD=$ORDER(^ADGDSI(OLD))
IF 'OLD
QUIT
Begin DoDot:1
+51 ;bad entry
IF $GET(^ADGDSI(OLD,0))=""
QUIT
+52 SET DFN=+$GET(^ADGDSI(OLD,0))
+53 ;
+54 ; add new entry
+55 SET OLD1=0
FOR
SET OLD1=$ORDER(^ADGDSI(OLD,"DT",OLD1))
IF 'OLD1
QUIT
Begin DoDot:2
+56 SET DATA=$GET(^ADGDSI(OLD,"DT",OLD1,0))
IF DATA=""
QUIT
+57 ;surg date
SET NEW=$GET(NEW)+1
SET ^BDGIC(NEW,0)=DFN_"^^^^"_(+DATA)
+58 SET $PIECE(^BDGIC(0),U,3)=NEW
SET $PIECE(^BDGIC(0),U,4)=$PIECE(^BDGIC(0),U,4)+1
+59 ;
+60 ; try to find PCC visit based on surgery date and patient
+61 SET X=$ORDER(^SRF("AIHS4",((+DATA)\1),DFN,0))
IF X
Begin DoDot:3
+62 SET V=$PIECE($GET(^SRF(X,9999999)),U)
IF V
SET $PIECE(^BDGIC(NEW,0),U,3)=V
End DoDot:3
+63 ;
+64 ; now copy data items to new location
+65 FOR I="5;4","4;18"
Begin DoDot:3
+66 SET $PIECE(^BDGIC(NEW,0),U,$PIECE(I,";",2))=$PIECE(DATA,U,+I)
End DoDot:3
+67 ;
+68 ; copy provider multiples
+69 ;start over for each patient
SET NEW2=1
+70 ;no provider entries to copy
IF '$DATA(^ADGDSI(OLD,"DT",OLD1,"P",0))
QUIT
+71 SET ^BDGIC(NEW,1,0)="^9009016.11P^"_$PIECE(^ADGDSI(OLD,"DT",OLD1,"P",0),U,3,4)
+72 ;
+73 SET OLD2=0
FOR
SET OLD2=$ORDER(^ADGDSI(OLD,"DT",OLD1,"P",OLD2))
IF 'OLD2
QUIT
Begin DoDot:3
+74 ;bad entry
IF $GET(^ADGDSI(OLD,"DT",OLD1,"P",OLD2,0))=""
QUIT
+75 ;
+76 ; now get chart deficiencies
+77 SET OLD3=0
+78 FOR
SET OLD3=$ORDER(^ADGDSI(OLD,"DT",OLD1,"P",OLD2,"CD",OLD3))
IF 'OLD3
QUIT
Begin DoDot:4
+79 SET DATA=$GET(^ADGDSI(OLD,"DT",OLD1,"P",OLD2,"CD",OLD3,0))
IF DATA=""
QUIT
+80 SET ^BDGIC(NEW,1,NEW2,0)=^ADGDSI(OLD,"DT",OLD1,"P",OLD2,0)
+81 SET $PIECE(^BDGIC(NEW,1,NEW2,0),U,2)=+DATA
+82 SET NEW2=NEW2+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+83 ;
+84 ;
+85 ; now index new file
+86 SET DIK="^BDGIC("
DO IXALL^DIK
+87 KILL X
SET X=$$REPEAT^XLFSTR(" ",20)_"Done."
DO MES^XPDUTL(.X)
+88 QUIT
