WVPRE ;HCIOFO/FT-Pre-Installation Routine ;9/16/98 13:06
;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
;
Q:'+$$VERSION^XPDUTL("BW") ;IHS WH not installed
Q:$D(^WV(790)) ;data transfer has been done already
D COPY
D NAME
D REPAIR
D FIELDS
D CREDIT
Q
COPY ; Copy data from IHS files into VISTA files.
; Does not delete IHS data.
D BMES^XPDUTL("Copying data from IHS files to VISTA Women's Health files.")
M ^WV(790)=^BWP
M ^WV(790.01)=^BWMGR
M ^WV(790.02)=^BWSITE
M ^WV(790.03)=^BWPR
M ^WV(790.04)=^BWPLOG
M ^WV(790.05)=^BWEDC
M ^WV(790.1)=^BWPCD
M ^WV(790.2)=^BWPN
M ^WV(790.31)=^BWDIAG
M ^WV(790.32)=^BWRADX
M ^WV(790.4)=^BWNOT
M ^WV(790.403)=^BWNOTT
M ^WV(790.404)=^BWNOTP
M ^WV(790.405)=^BWNOTO
M ^WV(790.5)=^BWCUR
M ^WV(790.51)=^BWMAMT
M ^WV(790.6)=^BWLET
M ^WV(790.71)=^BWSNAP
M ^WV(790.72)=^BWAGDF
Q
NAME ; Change file name and number on zero node
S WVX=789.9999
F S WVX=$O(^WV(WVX)) Q:'WVX D
.S WVNODE=$G(^WV(WVX,0))
.S WVNAME=$P(WVNODE,U,1),WVNAME="WV"_$P(WVNAME,"BW",2)
.S $P(WVNODE,U,1)=WVNAME
.S WVNUMBER=$P(WVNODE,U,2),WVNUMBER="790"_$P(WVNUMBER,"9002086",2)
.S WVNUMBER=WVNUMBER_$S(WVNUMBER["s":"",1:"s")
.S $P(WVNODE,U,2)=WVNUMBER
.S ^WV(WVX,0)=WVNODE
.Q
K WVX,WVNAME,WVNODE,WVNUMBER
Q
REPAIR ; Do data repair/clean up
D BMES^XPDUTL("Fixing data copied from IHS Women's Health files.")
; Change NEW status in File 790.1 to OPEN. NEW no longer exists.
S WVIEN=0
F S WVIEN=$O(^WV(790.1,WVIEN)) Q:'WVIEN D
.Q:$P(^WV(790.1,WVIEN,0),U,14)'="n"
.S $P(^WV(790.1,WVIEN,0),U,14)="o"
.K ^WV(790.1,"S","n",WVIEN)
.Q
; Change AGENCY value in File 790.02 to VA if not already VA
S WVIEN=0
F S WVIEN=$O(^WV(790.02,WVIEN)) Q:'WVIEN D
.Q:$P(^WV(790.02,WVIEN,0),U,15)="v"
.S $P(^WV(790.02,WVIEN,0),U,15)="v"
.Q
K WVIEN
Q
FIELDS ; Set deleted fields values to ""
; Set Date Inactive (File 790, #.24) if patient is dead.
; Kill X-refs on deleted fields
; ---> File 790, fld# .2 ("CDC")
; ---> File 790.1, fld# .17 "ACDC")
S WVX=0 F S WVX=$O(^WV(790,WVX)) Q:WVX'>0 D
.S $P(^WV(790,WVX,0),U,20)=""
.Q:$P(^WV(790,WVX,0),U,24) ;Date Inactive exists
.S WVDOD=$P($G(^DPT(WVX,.35)),U,1) ;date of death
.Q:'WVDOD
.S WVDOD=WVDOD\1
.S $P(^WV(790,WVX,0),U,24)=WVDOD
.Q
K ^WV(790,"CDC") S WVX=0
F S WVX=$O(^WV(790.02,WVX)) Q:WVX'>0 D
.F WVY=9,11,12,13,14,16,17,20 S $P(^WV(790.02,WVX,0),U,WVY)=""
.F WVY=1,2,3,4,7,8,17:1:35,37,38 S $P(^WV(790.02,WVX,WVY),U,2)=""
S WVX=0 F S WVX=$O(^WV(790.1,WVX)) Q:WVX'>0 D
.F WVY=3,16,17 S $P(^WV(790.1,WVX,0),U,WVY)=""
.K ^WV(790.1,WVX,"PCC")
.S WVQUAD=$P($G(^WV(790.1,WVX,2)),U,16)
.K ^WV(790.1,WVX,2)
.S:WVQUAD]"" $P(^WV(790.1,WVX,2),U,16)=WVQUAD
.Q
K ^WV(790.1,"ACDC")
S WVX=0 F S WVX=$O(^WV(790.2,WVX)) Q:WVX'>0 D
.F WVY=12:1:17 S $P(^WV(790.2,WVX,0),U,WVY)=""
S WVX=0 F S WVX=$O(^WV(790.31,WVX)) Q:WVX'>0 D
.F WVY=24:1:27 S $P(^WV(790.31,WVX,0),U,WVY)=""
S WVX=0
F S WVX=$O(^WV(790.51,WVX)) Q:WVX'>0 D
.S $P(^WV(790.51,WVX,0),U,2)=""
.Q
S WVX=0
F S WVX=$O(^WV(790.04,WVX)) Q:WVX'>0 D
.F WVY=5,6 S $P(^WV(790.04,WVX,0),U,WVY)=""
.Q
S WVX=0
F S WVX=$O(^WV(790.05,WVX)) Q:WVX'>0 D
.F WVY=5,6 S $P(^WV(790.05,WVX,0),U,WVY)=""
.Q
K WVDOD,WVQUAD,WVX,WVY
Q
CREDIT ; Stuff Credit Method value from Radiology/NM
; "E" x-ref on File 790.1 is rad/nm date-case # (e.g., 060898-94)
Q:'$D(^RADPT) ;no Radiology/NM Patient file (#70)
S WVX=""
F S WVX=$O(^WV(790.1,"E",WVX)) Q:WVX="" S WVY=0 F S WVY=$O(^WV(790.1,"E",WVX,WVY)) Q:'WVY D
.S WVNODE=$G(^WV(790.1,WVY,0)) Q:WVNODE=""
.S WVDFN=$P(WVNODE,U,2) Q:WVDFN=""
.D RADCHK
.Q:WVCM="" ;no credit method
.S $P(^WV(790.1,WVY,0),U,35)=WVCM
.Q
K WVCASE,WVCM,WVDATE,WVDFN,WVNODE,WVX,WVY
Q
RADCHK ; Get RAD/NM Patient Credit Method value
S WVCM=""
Q:'$D(^RADPT("ADC",WVX,WVDFN)) ;e.g., ^RADPT("ADC","060898-94",DFN))
S WVDATE=0
F S WVDATE=$O(^RADPT("ADC",WVX,WVDFN,WVDATE)) Q:'WVDATE S WVCASE=0 F S WVCASE=$O(^RADPT("ADC",WVX,WVDFN,WVDATE,WVCASE)) Q:'WVCASE D
.S WVCM=$P($G(^RADPT(WVDFN,"DT",WVDATE,"P",WVCASE,0)),U,26)
.Q
K WVCASE,WVDATE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVPRE 4175 printed Apr 09, 2024@21:50:05 Page 2
WVPRE ;HCIOFO/FT-Pre-Installation Routine ;9/16/98 13:06
+1 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
+2 ;
+3 ;IHS WH not installed
if '+$$VERSION^XPDUTL("BW")
QUIT
+4 ;data transfer has been done already
if $DATA(^WV(790))
QUIT
+5 DO COPY
+6 DO NAME
+7 DO REPAIR
+8 DO FIELDS
+9 DO CREDIT
+10 QUIT
COPY ; Copy data from IHS files into VISTA files.
+1 ; Does not delete IHS data.
+2 DO BMES^XPDUTL("Copying data from IHS files to VISTA Women's Health files.")
+3 MERGE ^WV(790)=^BWP
+4 MERGE ^WV(790.01)=^BWMGR
+5 MERGE ^WV(790.02)=^BWSITE
+6 MERGE ^WV(790.03)=^BWPR
+7 MERGE ^WV(790.04)=^BWPLOG
+8 MERGE ^WV(790.05)=^BWEDC
+9 MERGE ^WV(790.1)=^BWPCD
+10 MERGE ^WV(790.2)=^BWPN
+11 MERGE ^WV(790.31)=^BWDIAG
+12 MERGE ^WV(790.32)=^BWRADX
+13 MERGE ^WV(790.4)=^BWNOT
+14 MERGE ^WV(790.403)=^BWNOTT
+15 MERGE ^WV(790.404)=^BWNOTP
+16 MERGE ^WV(790.405)=^BWNOTO
+17 MERGE ^WV(790.5)=^BWCUR
+18 MERGE ^WV(790.51)=^BWMAMT
+19 MERGE ^WV(790.6)=^BWLET
+20 MERGE ^WV(790.71)=^BWSNAP
+21 MERGE ^WV(790.72)=^BWAGDF
+22 QUIT
NAME ; Change file name and number on zero node
+1 SET WVX=789.9999
+2 FOR
SET WVX=$ORDER(^WV(WVX))
if 'WVX
QUIT
Begin DoDot:1
+3 SET WVNODE=$GET(^WV(WVX,0))
+4 SET WVNAME=$PIECE(WVNODE,U,1)
SET WVNAME="WV"_$PIECE(WVNAME,"BW",2)
+5 SET $PIECE(WVNODE,U,1)=WVNAME
+6 SET WVNUMBER=$PIECE(WVNODE,U,2)
SET WVNUMBER="790"_$PIECE(WVNUMBER,"9002086",2)
+7 SET WVNUMBER=WVNUMBER_$SELECT(WVNUMBER["s":"",1:"s")
+8 SET $PIECE(WVNODE,U,2)=WVNUMBER
+9 SET ^WV(WVX,0)=WVNODE
+10 QUIT
End DoDot:1
+11 KILL WVX,WVNAME,WVNODE,WVNUMBER
+12 QUIT
REPAIR ; Do data repair/clean up
+1 DO BMES^XPDUTL("Fixing data copied from IHS Women's Health files.")
+2 ; Change NEW status in File 790.1 to OPEN. NEW no longer exists.
+3 SET WVIEN=0
+4 FOR
SET WVIEN=$ORDER(^WV(790.1,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:1
+5 if $PIECE(^WV(790.1,WVIEN,0),U,14)'="n"
QUIT
+6 SET $PIECE(^WV(790.1,WVIEN,0),U,14)="o"
+7 KILL ^WV(790.1,"S","n",WVIEN)
+8 QUIT
End DoDot:1
+9 ; Change AGENCY value in File 790.02 to VA if not already VA
+10 SET WVIEN=0
+11 FOR
SET WVIEN=$ORDER(^WV(790.02,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:1
+12 if $PIECE(^WV(790.02,WVIEN,0),U,15)="v"
QUIT
+13 SET $PIECE(^WV(790.02,WVIEN,0),U,15)="v"
+14 QUIT
End DoDot:1
+15 KILL WVIEN
+16 QUIT
FIELDS ; Set deleted fields values to ""
+1 ; Set Date Inactive (File 790, #.24) if patient is dead.
+2 ; Kill X-refs on deleted fields
+3 ; ---> File 790, fld# .2 ("CDC")
+4 ; ---> File 790.1, fld# .17 "ACDC")
+5 SET WVX=0
FOR
SET WVX=$ORDER(^WV(790,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+6 SET $PIECE(^WV(790,WVX,0),U,20)=""
+7 ;Date Inactive exists
if $PIECE(^WV(790,WVX,0),U,24)
QUIT
+8 ;date of death
SET WVDOD=$PIECE($GET(^DPT(WVX,.35)),U,1)
+9 if 'WVDOD
QUIT
+10 SET WVDOD=WVDOD\1
+11 SET $PIECE(^WV(790,WVX,0),U,24)=WVDOD
+12 QUIT
End DoDot:1
+13 KILL ^WV(790,"CDC")
SET WVX=0
+14 FOR
SET WVX=$ORDER(^WV(790.02,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+15 FOR WVY=9,11,12,13,14,16,17,20
SET $PIECE(^WV(790.02,WVX,0),U,WVY)=""
+16 FOR WVY=1,2,3,4,7,8,17:1:35,37,38
SET $PIECE(^WV(790.02,WVX,WVY),U,2)=""
End DoDot:1
+17 SET WVX=0
FOR
SET WVX=$ORDER(^WV(790.1,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+18 FOR WVY=3,16,17
SET $PIECE(^WV(790.1,WVX,0),U,WVY)=""
+19 KILL ^WV(790.1,WVX,"PCC")
+20 SET WVQUAD=$PIECE($GET(^WV(790.1,WVX,2)),U,16)
+21 KILL ^WV(790.1,WVX,2)
+22 if WVQUAD]""
SET $PIECE(^WV(790.1,WVX,2),U,16)=WVQUAD
+23 QUIT
End DoDot:1
+24 KILL ^WV(790.1,"ACDC")
+25 SET WVX=0
FOR
SET WVX=$ORDER(^WV(790.2,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+26 FOR WVY=12:1:17
SET $PIECE(^WV(790.2,WVX,0),U,WVY)=""
End DoDot:1
+27 SET WVX=0
FOR
SET WVX=$ORDER(^WV(790.31,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+28 FOR WVY=24:1:27
SET $PIECE(^WV(790.31,WVX,0),U,WVY)=""
End DoDot:1
+29 SET WVX=0
+30 FOR
SET WVX=$ORDER(^WV(790.51,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+31 SET $PIECE(^WV(790.51,WVX,0),U,2)=""
+32 QUIT
End DoDot:1
+33 SET WVX=0
+34 FOR
SET WVX=$ORDER(^WV(790.04,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+35 FOR WVY=5,6
SET $PIECE(^WV(790.04,WVX,0),U,WVY)=""
+36 QUIT
End DoDot:1
+37 SET WVX=0
+38 FOR
SET WVX=$ORDER(^WV(790.05,WVX))
if WVX'>0
QUIT
Begin DoDot:1
+39 FOR WVY=5,6
SET $PIECE(^WV(790.05,WVX,0),U,WVY)=""
+40 QUIT
End DoDot:1
+41 KILL WVDOD,WVQUAD,WVX,WVY
+42 QUIT
CREDIT ; Stuff Credit Method value from Radiology/NM
+1 ; "E" x-ref on File 790.1 is rad/nm date-case # (e.g., 060898-94)
+2 ;no Radiology/NM Patient file (#70)
if '$DATA(^RADPT)
QUIT
+3 SET WVX=""
+4 FOR
SET WVX=$ORDER(^WV(790.1,"E",WVX))
if WVX=""
QUIT
SET WVY=0
FOR
SET WVY=$ORDER(^WV(790.1,"E",WVX,WVY))
if 'WVY
QUIT
Begin DoDot:1
+5 SET WVNODE=$GET(^WV(790.1,WVY,0))
if WVNODE=""
QUIT
+6 SET WVDFN=$PIECE(WVNODE,U,2)
if WVDFN=""
QUIT
+7 DO RADCHK
+8 ;no credit method
if WVCM=""
QUIT
+9 SET $PIECE(^WV(790.1,WVY,0),U,35)=WVCM
+10 QUIT
End DoDot:1
+11 KILL WVCASE,WVCM,WVDATE,WVDFN,WVNODE,WVX,WVY
+12 QUIT
RADCHK ; Get RAD/NM Patient Credit Method value
+1 SET WVCM=""
+2 ;e.g., ^RADPT("ADC","060898-94",DFN))
if '$DATA(^RADPT("ADC",WVX,WVDFN))
QUIT
+3 SET WVDATE=0
+4 FOR
SET WVDATE=$ORDER(^RADPT("ADC",WVX,WVDFN,WVDATE))
if 'WVDATE
QUIT
SET WVCASE=0
FOR
SET WVCASE=$ORDER(^RADPT("ADC",WVX,WVDFN,WVDATE,WVCASE))
if 'WVCASE
QUIT
Begin DoDot:1
+5 SET WVCM=$PIECE($GET(^RADPT(WVDFN,"DT",WVDATE,"P",WVCASE,0)),U,26)
+6 QUIT
End DoDot:1
+7 KILL WVCASE,WVDATE
+8 QUIT
