- 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
