- 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 ""
