BWOLD ;IHS/ANMC/MWR - CONVERT DATA FROM OLD PAP PKG;
;;2.0;WOMEN'S HEALTH;;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CONVERT OLD DATA TO NEW. PROGRAMMER UTILITY, NOT CALLED
;; FROM MENUS.
;
W !!!?5,"WARNING! THIS ROUTINE SHOULD ONLY BE RUN ONCE AT A SITE!"
S DIR("A")=" Do you wish to continue"
S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !!
Q:$D(DIRUT)!(Y<1)
;
;
D SETVARS^BWUTL5
S (N,BWPATS,BWPAPS,BWCOLPS)=0
F S N=$O(^AMCH(86,N)) Q:'N D
.S M=0,BWDFN=N,BWPATS=BWPATS+1
.F S M=$O(^AMCH(86,N,"DS",M)) Q:'M D
..I $D(^AMCH(86,N,"DS",M,0)) D PAP
..S NN=0
..F S NN=$O(^AMCH(86,N,"DS",M,2,NN)) Q:'NN D
...I $D(^AMCH(86,N,"DS",M,2,NN,0)) D COLP
W !!?3,"PATIENTS ADDED: ",BWPATS
W ?28,"PAPS ADDED: ",BWPAPS
W ?52,"COLPOSCOPIES ADDED: ",BWCOLPS
W !!?10,"* DON'T FORGET TO CHECK GLOBAL ^BWOLD FOR ERRORS! *",!
Q
;
;
PAP ;EP
;---> COPY THIS PAP INTO NEW DATABASE.
N BWY,BWPOP S BWY=^AMCH(86,N,"DS",M,0),BWPOP=0
;---> BWDFN=DFN, BWPCDN=1="PAP SMEAR", BWDATE=DATE OF PAP.
S BWPCDN=1,BWDATE=$P(BWY,U)
;---> SET PRIMARY AND SECONDARY DIAGNOSES FOR THIS PAP.
S BW1DX=$P(BWY,U,2),BW1DX=$$PAPDX(BW1DX)
S BW2DX=$P(BWY,U,3),BW2DX=$$PAPDX(BW2DX)
;
I '$D(^AUPNPAT(BWDFN)) D Q
.S ^BWOLD(N,M,"PAT")="PATIENT DOES NOT EXIST IN PATIENT FILE."
;
;---> IF PATIENT IS NOT ALREADY IN DATABASE, ADD HER.
S BWERR=1
D:'$D(^BWP(BWDFN)) AUTOADD^BWPATE(BWDFN,DUZ(2),.BWERR)
I BWERR<0 S ^BWOLD(N,M,"PAT")="FAILED TO ADD PATIENT." Q
;
;---> NOW GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
S X=$$ACCSSN^BWUTL5(1)
I X']"" S ^BWOLD(N,M,"ACC#")="FAILED TO ADD ACC#." Q
;
;---> NOW ADD(TRANSFER) THE PROCEDURE.
S DIC("DR")=".02////"_BWDFN_";.04////"_BWPCDN_";.12////"_BWDATE
S DIC("DR")=DIC("DR")_";.05////"_BW1DX_";.06////"_BW2DX_";.14////c"
K DD,DO S DIC="^BWPCD(",DIC(0)="ML",DLAYGO=9002086
D FILE^DICN
W !?3,$$NAME^BWUTL1(BWDFN),?35,$$HRCN^BWUTL1(BWDFN)
W ?45,"ACC#: ",$P(Y,U,2)
S BWPAPS=BWPAPS+1
;---> IF Y<0, CHECK PERMISSIONS.
I Y<0 S ^BWOLD(N,M,"PCD")="UNABLE TO CREATE NEW PROCEDURE."
Q
;
;
COLP ;EP
;---> COPY THIS COLP INTO NEW DATABASE.
N BWY S BWY=^AMCH(86,N,"DS",M,2,NN,0)
;---> BWDFN=DFN, BWPCDN=2="COLPOSCOPY", BWDATE=DATE OF COLP.
S BWDFN=N,BWPCDN=2,BWDATE=$P(BWY,U)
;---> SET PRIMARY AND SECONDARY DIAGNOSES FOR THIS PAP.
S BW1DX=$P(BWY,U,2),BW1DX=$$COLPDX(BW1DX)
S BW2DX=$P(BWY,U,5),BW2DX=$$COLPDX(BW2DX)
;
;---> NOW GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
S X=$$ACCSSN^BWUTL5(2)
I X']"" S ^BWOLD(N,M,NN,"ACC#")="FAILED TO ADD ACC#." Q
S DIC("DR")=".02////"_BWDFN_";.04////"_BWPCDN_";.12////"_BWDATE
S DIC("DR")=DIC("DR")_";.05////"_BW1DX_";.26////"_BW2DX_";.14////c"
K DD,DO S DIC="^BWPCD(",DIC(0)="ML",DLAYGO=9002086
D FILE^DICN
W !?3,$$NAME^BWUTL1(BWDFN),?35,$$HRCN^BWUTL1(BWDFN)
W ?45,"ACC#: ",$P(Y,U,2)
S BWCOLPS=BWCOLPS+1
;---> IF Y<0, CHECK PERMISSIONS.
I Y<0 S ^BWOLD(N,M,NN,"PCD")="UNABLE TO CREATE NEW PROCEDURE."
Q
;
PAPDX(Y) ;EP
;---> THE Y=IEN IN ^AMCH(86.1 - OLD PAP RESULTS FILE #9002086.1
Q:Y="" ""
Q:Y=3 5
Q:Y=5 3
Q:Y=6 42
Q:Y=7 11
Q:Y=12 12
Q:Y=14 46
Q:Y=15 13
Q:Y=16 33
Q:Y=17 33
Q:Y=19 32
Q:Y=21 50
Q:Y=22 22
Q:Y=23 39
Q ""
;
COLPDX(Y) ;EP
;---> THE Y=IEN IN ^AMCH(86.3 - OLD COLPO&BIOPSY DIAG FILE #9002086.3
Q:Y="" ""
Q:Y=1 11
Q:Y=2 30
Q:Y=3 30
Q:Y=4 15
Q:Y=5 15
Q:Y=6 16
Q:Y=7 16
Q:Y=8 17
Q:Y=9 18
Q:Y=10 19
Q:Y=11 1
Q:Y=12 1
Q:Y=13 1
Q:Y=14 12
Q:Y=15 32
Q:Y=16 51
Q ""
BWOLD ;IHS/ANMC/MWR - CONVERT DATA FROM OLD PAP PKG;
+1 ;;2.0;WOMEN'S HEALTH;;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CONVERT OLD DATA TO NEW. PROGRAMMER UTILITY, NOT CALLED
+4 ;; FROM MENUS.
+5 ;
+6 WRITE !!!?5,"WARNING! THIS ROUTINE SHOULD ONLY BE RUN ONCE AT A SITE!"
+7 SET DIR("A")=" Do you wish to continue"
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
WRITE !!
+9 IF $DATA(DIRUT)!(Y<1)
QUIT
+10 ;
+11 ;
+12 DO SETVARS^BWUTL5
+13 SET (N,BWPATS,BWPAPS,BWCOLPS)=0
+14 FOR
SET N=$ORDER(^AMCH(86,N))
IF 'N
QUIT
Begin DoDot:1
+15 SET M=0
SET BWDFN=N
SET BWPATS=BWPATS+1
+16 FOR
SET M=$ORDER(^AMCH(86,N,"DS",M))
IF 'M
QUIT
Begin DoDot:2
+17 IF $DATA(^AMCH(86,N,"DS",M,0))
DO PAP
+18 SET NN=0
+19 FOR
SET NN=$ORDER(^AMCH(86,N,"DS",M,2,NN))
IF 'NN
QUIT
Begin DoDot:3
+20 IF $DATA(^AMCH(86,N,"DS",M,2,NN,0))
DO COLP
End DoDot:3
End DoDot:2
End DoDot:1
+21 WRITE !!?3,"PATIENTS ADDED: ",BWPATS
+22 WRITE ?28,"PAPS ADDED: ",BWPAPS
+23 WRITE ?52,"COLPOSCOPIES ADDED: ",BWCOLPS
+24 WRITE !!?10,"* DON'T FORGET TO CHECK GLOBAL ^BWOLD FOR ERRORS! *",!
+25 QUIT
+26 ;
+27 ;
PAP ;EP
+1 ;---> COPY THIS PAP INTO NEW DATABASE.
+2 NEW BWY,BWPOP
SET BWY=^AMCH(86,N,"DS",M,0)
SET BWPOP=0
+3 ;---> BWDFN=DFN, BWPCDN=1="PAP SMEAR", BWDATE=DATE OF PAP.
+4 SET BWPCDN=1
SET BWDATE=$PIECE(BWY,U)
+5 ;---> SET PRIMARY AND SECONDARY DIAGNOSES FOR THIS PAP.
+6 SET BW1DX=$PIECE(BWY,U,2)
SET BW1DX=$$PAPDX(BW1DX)
+7 SET BW2DX=$PIECE(BWY,U,3)
SET BW2DX=$$PAPDX(BW2DX)
+8 ;
+9 IF '$DATA(^AUPNPAT(BWDFN))
Begin DoDot:1
+10 SET ^BWOLD(N,M,"PAT")="PATIENT DOES NOT EXIST IN PATIENT FILE."
End DoDot:1
QUIT
+11 ;
+12 ;---> IF PATIENT IS NOT ALREADY IN DATABASE, ADD HER.
+13 SET BWERR=1
+14 IF '$DATA(^BWP(BWDFN))
DO AUTOADD^BWPATE(BWDFN,DUZ(2),.BWERR)
+15 IF BWERR<0
SET ^BWOLD(N,M,"PAT")="FAILED TO ADD PATIENT."
QUIT
+16 ;
+17 ;---> NOW GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
+18 SET X=$$ACCSSN^BWUTL5(1)
+19 IF X']""
SET ^BWOLD(N,M,"ACC#")="FAILED TO ADD ACC#."
QUIT
+20 ;
+21 ;---> NOW ADD(TRANSFER) THE PROCEDURE.
+22 SET DIC("DR")=".02////"_BWDFN_";.04////"_BWPCDN_";.12////"_BWDATE
+23 SET DIC("DR")=DIC("DR")_";.05////"_BW1DX_";.06////"_BW2DX_";.14////c"
+24 KILL DD,DO
SET DIC="^BWPCD("
SET DIC(0)="ML"
SET DLAYGO=9002086
+25 DO FILE^DICN
+26 WRITE !?3,$$NAME^BWUTL1(BWDFN),?35,$$HRCN^BWUTL1(BWDFN)
+27 WRITE ?45,"ACC#: ",$PIECE(Y,U,2)
+28 SET BWPAPS=BWPAPS+1
+29 ;---> IF Y<0, CHECK PERMISSIONS.
+30 IF Y<0
SET ^BWOLD(N,M,"PCD")="UNABLE TO CREATE NEW PROCEDURE."
+31 QUIT
+32 ;
+33 ;
COLP ;EP
+1 ;---> COPY THIS COLP INTO NEW DATABASE.
+2 NEW BWY
SET BWY=^AMCH(86,N,"DS",M,2,NN,0)
+3 ;---> BWDFN=DFN, BWPCDN=2="COLPOSCOPY", BWDATE=DATE OF COLP.
+4 SET BWDFN=N
SET BWPCDN=2
SET BWDATE=$PIECE(BWY,U)
+5 ;---> SET PRIMARY AND SECONDARY DIAGNOSES FOR THIS PAP.
+6 SET BW1DX=$PIECE(BWY,U,2)
SET BW1DX=$$COLPDX(BW1DX)
+7 SET BW2DX=$PIECE(BWY,U,5)
SET BW2DX=$$COLPDX(BW2DX)
+8 ;
+9 ;---> NOW GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
+10 SET X=$$ACCSSN^BWUTL5(2)
+11 IF X']""
SET ^BWOLD(N,M,NN,"ACC#")="FAILED TO ADD ACC#."
QUIT
+12 SET DIC("DR")=".02////"_BWDFN_";.04////"_BWPCDN_";.12////"_BWDATE
+13 SET DIC("DR")=DIC("DR")_";.05////"_BW1DX_";.26////"_BW2DX_";.14////c"
+14 KILL DD,DO
SET DIC="^BWPCD("
SET DIC(0)="ML"
SET DLAYGO=9002086
+15 DO FILE^DICN
+16 WRITE !?3,$$NAME^BWUTL1(BWDFN),?35,$$HRCN^BWUTL1(BWDFN)
+17 WRITE ?45,"ACC#: ",$PIECE(Y,U,2)
+18 SET BWCOLPS=BWCOLPS+1
+19 ;---> IF Y<0, CHECK PERMISSIONS.
+20 IF Y<0
SET ^BWOLD(N,M,NN,"PCD")="UNABLE TO CREATE NEW PROCEDURE."
+21 QUIT
+22 ;
PAPDX(Y) ;EP
+1 ;---> THE Y=IEN IN ^AMCH(86.1 - OLD PAP RESULTS FILE #9002086.1
+2 IF Y=""
QUIT ""
+3 IF Y=3
QUIT 5
+4 IF Y=5
QUIT 3
+5 IF Y=6
QUIT 42
+6 IF Y=7
QUIT 11
+7 IF Y=12
QUIT 12
+8 IF Y=14
QUIT 46
+9 IF Y=15
QUIT 13
+10 IF Y=16
QUIT 33
+11 IF Y=17
QUIT 33
+12 IF Y=19
QUIT 32
+13 IF Y=21
QUIT 50
+14 IF Y=22
QUIT 22
+15 IF Y=23
QUIT 39
+16 QUIT ""
+17 ;
COLPDX(Y) ;EP
+1 ;---> THE Y=IEN IN ^AMCH(86.3 - OLD COLPO&BIOPSY DIAG FILE #9002086.3
+2 IF Y=""
QUIT ""
+3 IF Y=1
QUIT 11
+4 IF Y=2
QUIT 30
+5 IF Y=3
QUIT 30
+6 IF Y=4
QUIT 15
+7 IF Y=5
QUIT 15
+8 IF Y=6
QUIT 16
+9 IF Y=7
QUIT 16
+10 IF Y=8
QUIT 17
+11 IF Y=9
QUIT 18
+12 IF Y=10
QUIT 19
+13 IF Y=11
QUIT 1
+14 IF Y=12
QUIT 1
+15 IF Y=13
QUIT 1
+16 IF Y=14
QUIT 12
+17 IF Y=15
QUIT 32
+18 IF Y=16
QUIT 51
+19 QUIT ""
