ADGCP ; IHS/ADC/PDW/ENM - provider conversion ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
; label V stuffs visit pointer in 405
;
A ; -- main
;searhc/maw added this stuff
W !!!,"Do not run this post init until you VERIFY COMPLETION ",!,"of the DGPM5 PARTS 1 & 2 Conversions...",!! ;IHS/DSD/ENM 03/06/99
W *7,*7 H 3 W *7,*7 ;IHS/DSD/ENM 03/06/99
S DIR(0)="Y",DIR("A")="Do you wish to continue "
D ^DIR
Q:$D(DIRUT)
S YN=Y
Q:Y<1
;
;searhc/maw end of added stuff
;
W !!!,"Converting provider pointers to file 200..."
D PM1,PM2,TS,HL,PT,IC,SV,DSIC,DS,V
Q
;
IC ; -- incomplete chart
W !!,"converting incomplete chart providers ...."
N X,Y,Z,C,P,V S C=$P($G(^DG5(1,"IHS")),U,2) Q:C="C"
K ^ADGIC("AC")
S X=$S(C:C,1:0) F S X=$O(^ADGIC(X)) Q:'X D
. S Y=0 F S Y=$O(^ADGIC(X,"D",Y)) Q:'Y D
.. S Z=0 F S Z=$O(^ADGIC(X,"D",Y,"P",Z)) Q:'Z D
... S P=+$G(^ADGIC(X,"D",Y,"P",Z,0)) Q:'P
... S V=$G(^DIC(16,P,"A3")) Q:'V
... S $P(^ADGIC(X,"D",Y,"P",Z,0),U)=V
... K ^ADGIC(X,"D",Y,"P","B",P,Z)
... S ^ADGIC(X,"D",Y,"P","B",V,Z)=""
... S ^ADGIC("AC",V,X,Y,Z)=""
... S $P(^DG5(1,"IHS"),U,2)=X
S $P(^DG5(1,"IHS"),U,2)="C"
Q
;
DSIC ; -- day surgery incomplete chart
W !!,"converting day surgery incomplete chart providers ...."
N X,Y,Z,C,P,V S C=$P($G(^DG5(1,"IHS")),U,3) Q:C="C"
K ^ADGDSI("AC")
S X=$S(C:C,1:0) F S X=$O(^ADGDSI(X)) Q:'X D
. S Y=0 F S Y=$O(^ADGDSI(X,"DT",Y)) Q:'Y D
.. S Z=0 F S Z=$O(^ADGDSI(X,"DT",Y,"P",Z)) Q:'Z D
... S P=+$G(^ADGDSI(X,"DT",Y,"P",Z,0)) Q:'P
... S V=$G(^DIC(16,P,"A3")) Q:'V
... S $P(^ADGDSI(X,"DT",Y,"P",Z,0),U)=V
... K ^ADGDSI(X,"DT",Y,"P","B",P,Z)
... S ^ADGDSI(X,"DT",Y,"P","B",V,Z)=""
... S ^ADGDSI("AC",V,X,Y,Z)=""
... S $P(^DG5(1,"IHS"),U,3)=X
S $P(^DG5(1,"IHS"),U,3)="C"
Q
;
DS ; -- day surgery
W !!,"converting day surgery providers ...."
N X,Y,C,P,V S C=$P($G(^DG5(1,"IHS")),U,4) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^ADGDS(X)) Q:'X D
. S Y=0 F S Y=$O(^ADGDS(X,"DS",Y)) Q:'Y D
.. S P=+$P($G(^ADGDS(X,"DS",Y,0)),U,6) Q:'P
.. S V=$G(^DIC(16,P,"A3")) Q:'V
.. S $P(^ADGDS(X,"DS",Y,0),U,6)=V
.. S $P(^DG5(1,"IHS"),U,4)=X
S $P(^DG5(1,"IHS"),U,4)="C"
Q
;
SV ; -- scheduled visit
W !!,"converting scheduled visit providers ...."
N X,Y,C,P,V S C=$P($G(^DG5(1,"IHS")),U,5) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^ADGAUTH(X)) Q:'X D
. S Y=0 F S Y=$O(^ADGAUTH(X,1,Y)) Q:'Y D
.. S P=+$P($G(^ADGAUTH(X,1,Y,0)),U,2) Q:'P
.. S V=$G(^DIC(16,P,"A3")) Q:'V
.. S $P(^ADGAUTH(X,1,Y,0),U,2)=V
.. S $P(^DG5(1,"IHS"),U,5)=X
S $P(^DG5(1,"IHS"),U,5)="C"
Q
;
PM1 ; -- patient movement, primary care
W !!,"converting patient movement admitting providers ...."
N X,C,P,V S C=$P($G(^DG5(1,"IHS")),U,6) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^DGPM(X)) Q:'X D
. S P=+$P($G(^DGPM(X,0)),U,8) Q:'P
. S V=$G(^DIC(16,P,"A3")) Q:'V
. S $P(^DGPM(X,0),U,8)=V
. S $P(^DG5(1,"IHS"),U,6)=X
S $P(^DG5(1,"IHS"),U,6)="C"
Q
;
PM2 ; -- patient movement, attending
W !!,"converting patient movement attending providers ...."
N X,C,P,V S C=$P($G(^DG5(1,"IHS")),U,7) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^DGPM(X)) Q:'X D
. S P=+$P($G(^DGPM(X,0)),U,16) Q:'P
. S V=$G(^DIC(16,P,"A3")) Q:'V
. S $P(^DGPM(X,0),U,16)=V
. S $P(^DG5(1,"IHS"),U,7)=X
S $P(^DG5(1,"IHS"),U,7)="C"
Q
;
TS ; -- treating specialty
W !!,"converting treating specialty providers ...."
N X,Y,C,P,V S C=$P($G(^DG5(1,"IHS")),U,8) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^DIC(45.7,X)) Q:'X D
. S Y=0 F S Y=$O(^DIC(45.7,X,"PRO",Y)) Q:'Y D
.. S P=+$G(^DIC(45.7,X,"PRO",Y,0)) Q:'P
.. S V=$G(^DIC(16,P,"A3")) Q:'V
.. S $P(^DIC(45.7,X,"DS",Y,0),U)=V
.. S $P(^DG5(1,"IHS"),U,8)=X
S $P(^DG5(1,"IHS"),U,8)="C"
Q
;
HL ; -- hospital location
W !!,"converting hospital location default providers ...."
N X,C,P,V S C=$P($G(^DG5(1,"IHS")),U,9) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^SC(X)) Q:'X D
. S P=+$P($G(^SC(X,0)),U,13) Q:'P
. S V=$G(^DIC(16,P,"A3")) Q:'V
. S $P(^SC(X,0),U,13)=V
. S $P(^DG5(1,"IHS"),U,9)=X
S $P(^DG5(1,"IHS"),U,9)="C"
Q
;
PT ; -- va patient
W !!,"converting patient file providers ...."
N X,C,P,V S C=$P($G(^DG5(1,"IHS")),U,10) Q:C="C"
S X=$S(C:C,1:0) F S X=$O(^DPT(X)) Q:'X D
. S P=+$G(^DPT(X,.104)) Q:'P
. S V=$G(^DIC(16,P,"A3")) Q:'V
. S $P(^DPT(X,.104),U)=V
. K ^DPT("APR",P,X)
. S ^DPT("APR",V,X)=""
. D PT2
. S $P(^DG5(1,"IHS"),U,10)=X
S $P(^DG5(1,"IHS"),U,10)="C"
Q
;
PT2 ; -- va patient admission multiple
N A,P,V,T
S A=0 F S A=$O(^DPT(X,"DA",A)) Q:'A D
. S T=0 F S T=$O(^DPT(X,"DA",A,"T",T)) Q:'T D
.. S P=$P($G(^DPT(X,"DA",A,"T",T,0)),U,3) Q:P=""
.. S V=$G(^DIC(16,P,"A3")) Q:'V
.. S $P(^DPT(X,"DA",A,"T",T,0),U,3)=V
Q
;
V ; -- populate 405 /visit ptr
W !!,"stuffing visit pointers in admission entries..."
N DATE,DFN,IFN
S DATE=0 F S DATE=$O(^DGPM("AMV1",DATE)) Q:'DATE D
. S DFN=0 F S DFN=$O(^DGPM("AMV1",DATE,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV1",DATE,DFN,IFN)) Q:'IFN D
... S:'$G(^DGPM(IFN,"IHS")) $P(^DGPM(IFN,"IHS"),U)=$$VIC(IFN,DFN)
... S:'$G(^DGPM(IFN,"IHS")) $P(^DGPM(IFN,"IHS"),U)=$$V1(IFN,DFN)
Q
;
VIC(I,J) ; -- visit ien (I=admission IEN,J=patient DFN)
N X,Y S (X,Y)=0
F S X=$O(^AUPNVSIT("AA",+J,+$$IDC(I),X)) Q:'X Q:Y D
. I $P($G(^AUPNVSIT(X,0)),U,7)="H" S Y=X
Q Y
;
IDC(I) ; -- inverse date
Q (9999999-$P(+^DGPM(+I,0),"."))_"."_$P(+^DGPM(+I,0),".",2)
;
V1(I,J) ; -- visit ien (I=admission IEN,J=patient DFN)
N X,Y S (X,Y)=0
F S X=$O(^AUPNVSIT("AA",+J,+$$I1(I),X)) Q:'X Q:Y D
. I $P($G(^AUPNVSIT(X,0)),U,7)="H" S Y=X
Q Y
;
I1(I) ; -- inverse date
Q (9999999-$P(+^DGPM(+I,0),"."))
ADGCP ; IHS/ADC/PDW/ENM - provider conversion ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ; label V stuffs visit pointer in 405
+4 ;
A ; -- main
+1 ;searhc/maw added this stuff
+2 ;IHS/DSD/ENM 03/06/99
WRITE !!!,"Do not run this post init until you VERIFY COMPLETION ",!,"of the DGPM5 PARTS 1 & 2 Conversions...",!!
+3 ;IHS/DSD/ENM 03/06/99
WRITE *7,*7
HANG 3
WRITE *7,*7
+4 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue "
+5 DO ^DIR
+6 IF $DATA(DIRUT)
QUIT
+7 SET YN=Y
+8 IF Y<1
QUIT
+9 ;
+10 ;searhc/maw end of added stuff
+11 ;
+12 WRITE !!!,"Converting provider pointers to file 200..."
+13 DO PM1
DO PM2
DO TS
DO HL
DO PT
DO IC
DO SV
DO DSIC
DO DS
DO V
+14 QUIT
+15 ;
IC ; -- incomplete chart
+1 WRITE !!,"converting incomplete chart providers ...."
+2 NEW X,Y,Z,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,2)
IF C="C"
QUIT
+3 KILL ^ADGIC("AC")
+4 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^ADGIC(X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^ADGIC(X,"D",Y))
IF 'Y
QUIT
Begin DoDot:2
+6 SET Z=0
FOR
SET Z=$ORDER(^ADGIC(X,"D",Y,"P",Z))
IF 'Z
QUIT
Begin DoDot:3
+7 SET P=+$GET(^ADGIC(X,"D",Y,"P",Z,0))
IF 'P
QUIT
+8 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+9 SET $PIECE(^ADGIC(X,"D",Y,"P",Z,0),U)=V
+10 KILL ^ADGIC(X,"D",Y,"P","B",P,Z)
+11 SET ^ADGIC(X,"D",Y,"P","B",V,Z)=""
+12 SET ^ADGIC("AC",V,X,Y,Z)=""
+13 SET $PIECE(^DG5(1,"IHS"),U,2)=X
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET $PIECE(^DG5(1,"IHS"),U,2)="C"
+15 QUIT
+16 ;
DSIC ; -- day surgery incomplete chart
+1 WRITE !!,"converting day surgery incomplete chart providers ...."
+2 NEW X,Y,Z,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,3)
IF C="C"
QUIT
+3 KILL ^ADGDSI("AC")
+4 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^ADGDSI(X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^ADGDSI(X,"DT",Y))
IF 'Y
QUIT
Begin DoDot:2
+6 SET Z=0
FOR
SET Z=$ORDER(^ADGDSI(X,"DT",Y,"P",Z))
IF 'Z
QUIT
Begin DoDot:3
+7 SET P=+$GET(^ADGDSI(X,"DT",Y,"P",Z,0))
IF 'P
QUIT
+8 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+9 SET $PIECE(^ADGDSI(X,"DT",Y,"P",Z,0),U)=V
+10 KILL ^ADGDSI(X,"DT",Y,"P","B",P,Z)
+11 SET ^ADGDSI(X,"DT",Y,"P","B",V,Z)=""
+12 SET ^ADGDSI("AC",V,X,Y,Z)=""
+13 SET $PIECE(^DG5(1,"IHS"),U,3)=X
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET $PIECE(^DG5(1,"IHS"),U,3)="C"
+15 QUIT
+16 ;
DS ; -- day surgery
+1 WRITE !!,"converting day surgery providers ...."
+2 NEW X,Y,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,4)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^ADGDS(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=0
FOR
SET Y=$ORDER(^ADGDS(X,"DS",Y))
IF 'Y
QUIT
Begin DoDot:2
+5 SET P=+$PIECE($GET(^ADGDS(X,"DS",Y,0)),U,6)
IF 'P
QUIT
+6 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+7 SET $PIECE(^ADGDS(X,"DS",Y,0),U,6)=V
+8 SET $PIECE(^DG5(1,"IHS"),U,4)=X
End DoDot:2
End DoDot:1
+9 SET $PIECE(^DG5(1,"IHS"),U,4)="C"
+10 QUIT
+11 ;
SV ; -- scheduled visit
+1 WRITE !!,"converting scheduled visit providers ...."
+2 NEW X,Y,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,5)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^ADGAUTH(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=0
FOR
SET Y=$ORDER(^ADGAUTH(X,1,Y))
IF 'Y
QUIT
Begin DoDot:2
+5 SET P=+$PIECE($GET(^ADGAUTH(X,1,Y,0)),U,2)
IF 'P
QUIT
+6 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+7 SET $PIECE(^ADGAUTH(X,1,Y,0),U,2)=V
+8 SET $PIECE(^DG5(1,"IHS"),U,5)=X
End DoDot:2
End DoDot:1
+9 SET $PIECE(^DG5(1,"IHS"),U,5)="C"
+10 QUIT
+11 ;
PM1 ; -- patient movement, primary care
+1 WRITE !!,"converting patient movement admitting providers ...."
+2 NEW X,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,6)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^DGPM(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET P=+$PIECE($GET(^DGPM(X,0)),U,8)
IF 'P
QUIT
+5 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+6 SET $PIECE(^DGPM(X,0),U,8)=V
+7 SET $PIECE(^DG5(1,"IHS"),U,6)=X
End DoDot:1
+8 SET $PIECE(^DG5(1,"IHS"),U,6)="C"
+9 QUIT
+10 ;
PM2 ; -- patient movement, attending
+1 WRITE !!,"converting patient movement attending providers ...."
+2 NEW X,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,7)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^DGPM(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET P=+$PIECE($GET(^DGPM(X,0)),U,16)
IF 'P
QUIT
+5 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+6 SET $PIECE(^DGPM(X,0),U,16)=V
+7 SET $PIECE(^DG5(1,"IHS"),U,7)=X
End DoDot:1
+8 SET $PIECE(^DG5(1,"IHS"),U,7)="C"
+9 QUIT
+10 ;
TS ; -- treating specialty
+1 WRITE !!,"converting treating specialty providers ...."
+2 NEW X,Y,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,8)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^DIC(45.7,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=0
FOR
SET Y=$ORDER(^DIC(45.7,X,"PRO",Y))
IF 'Y
QUIT
Begin DoDot:2
+5 SET P=+$GET(^DIC(45.7,X,"PRO",Y,0))
IF 'P
QUIT
+6 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+7 SET $PIECE(^DIC(45.7,X,"DS",Y,0),U)=V
+8 SET $PIECE(^DG5(1,"IHS"),U,8)=X
End DoDot:2
End DoDot:1
+9 SET $PIECE(^DG5(1,"IHS"),U,8)="C"
+10 QUIT
+11 ;
HL ; -- hospital location
+1 WRITE !!,"converting hospital location default providers ...."
+2 NEW X,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,9)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^SC(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET P=+$PIECE($GET(^SC(X,0)),U,13)
IF 'P
QUIT
+5 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+6 SET $PIECE(^SC(X,0),U,13)=V
+7 SET $PIECE(^DG5(1,"IHS"),U,9)=X
End DoDot:1
+8 SET $PIECE(^DG5(1,"IHS"),U,9)="C"
+9 QUIT
+10 ;
PT ; -- va patient
+1 WRITE !!,"converting patient file providers ...."
+2 NEW X,C,P,V
SET C=$PIECE($GET(^DG5(1,"IHS")),U,10)
IF C="C"
QUIT
+3 SET X=$SELECT(C:C,1:0)
FOR
SET X=$ORDER(^DPT(X))
IF 'X
QUIT
Begin DoDot:1
+4 SET P=+$GET(^DPT(X,.104))
IF 'P
QUIT
+5 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+6 SET $PIECE(^DPT(X,.104),U)=V
+7 KILL ^DPT("APR",P,X)
+8 SET ^DPT("APR",V,X)=""
+9 DO PT2
+10 SET $PIECE(^DG5(1,"IHS"),U,10)=X
End DoDot:1
+11 SET $PIECE(^DG5(1,"IHS"),U,10)="C"
+12 QUIT
+13 ;
PT2 ; -- va patient admission multiple
+1 NEW A,P,V,T
+2 SET A=0
FOR
SET A=$ORDER(^DPT(X,"DA",A))
IF 'A
QUIT
Begin DoDot:1
+3 SET T=0
FOR
SET T=$ORDER(^DPT(X,"DA",A,"T",T))
IF 'T
QUIT
Begin DoDot:2
+4 SET P=$PIECE($GET(^DPT(X,"DA",A,"T",T,0)),U,3)
IF P=""
QUIT
+5 SET V=$GET(^DIC(16,P,"A3"))
IF 'V
QUIT
+6 SET $PIECE(^DPT(X,"DA",A,"T",T,0),U,3)=V
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
V ; -- populate 405 /visit ptr
+1 WRITE !!,"stuffing visit pointers in admission entries..."
+2 NEW DATE,DFN,IFN
+3 SET DATE=0
FOR
SET DATE=$ORDER(^DGPM("AMV1",DATE))
IF 'DATE
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",DATE,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+5 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV1",DATE,DFN,IFN))
IF 'IFN
QUIT
Begin DoDot:3
+6 IF '$GET(^DGPM(IFN,"IHS"))
SET $PIECE(^DGPM(IFN,"IHS"),U)=$$VIC(IFN,DFN)
+7 IF '$GET(^DGPM(IFN,"IHS"))
SET $PIECE(^DGPM(IFN,"IHS"),U)=$$V1(IFN,DFN)
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
VIC(I,J) ; -- visit ien (I=admission IEN,J=patient DFN)
+1 NEW X,Y
SET (X,Y)=0
+2 FOR
SET X=$ORDER(^AUPNVSIT("AA",+J,+$$IDC(I),X))
IF 'X
QUIT
IF Y
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVSIT(X,0)),U,7)="H"
SET Y=X
End DoDot:1
+4 QUIT Y
+5 ;
IDC(I) ; -- inverse date
+1 QUIT (9999999-$PIECE(+^DGPM(+I,0),"."))_"."_$PIECE(+^DGPM(+I,0),".",2)
+2 ;
V1(I,J) ; -- visit ien (I=admission IEN,J=patient DFN)
+1 NEW X,Y
SET (X,Y)=0
+2 FOR
SET X=$ORDER(^AUPNVSIT("AA",+J,+$$I1(I),X))
IF 'X
QUIT
IF Y
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVSIT(X,0)),U,7)="H"
SET Y=X
End DoDot:1
+4 QUIT Y
+5 ;
I1(I) ; -- inverse date
+1 QUIT (9999999-$PIECE(+^DGPM(+I,0),"."))
