WVEXPTRA ;HCIOFO/FT-EXPORT MAMS & ULTRASOUNDS TO WOMEN'S HEALTH ;04/15/2021
;;1.0;WOMEN'S HEALTH;**3,5,7,10,26**;Sep 30, 1998;Build 624
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;---> WVNEWP = TOTAL NEW WOMEN'S HEALTH PATIENTS ADDED.
;---> WVMAM = TOTAL NEW MAMMOGRAMS PROCEDURES ADDED.
;
EN1 ;
S WVPOP=0,WVEC=""
D CHECK I WVPOP D KILL Q ;check if site parameter entry exists
D DESC ;describe option
D DTRNG I WVPOP D KILL Q ;get date range
D STATUS I WVPOP D KILL Q ;select status of procedure
D EC^WVGETAL1 I WVPOP D KILL Q ;veterans/non-vets/eligibility code
D QUEUE ;queue a background job
D KILL
Q
EN2 ;
D CPTS ;get procedure pointers
D GET ;get RAD/NM data & store in WH
D MAIL ;send mail message to user
D KILL ;kill variables
Q
DESC ; Describe option
W @IOF
W !,"This option searches the Radiology/Nuclear Medicine database for"
W !,"all female patients who had a mammogram, breast ultrasound, pelvic"
W !,"ultrasound or vaginal ultrasound exam during the date range you select."
W !,"These procedures and patients will be added to the WH database if"
W !,"not already there.",!
W !,"This job will be queued as a background task so as to free up your"
W !,"terminal to do other work. You will receive a mail message when"
W !,"the job is done. The mail message will contain a count of the"
W !,"number of procedures and patients added.",!!
Q
CHECK ; Check if DUZ(2) exists for user, if entry exists in site parameter
; file, if case manager, and if File 70 exists.
D CHECK^WVLOGO
I '$G(DUZ(2))!('$D(^WV(790.02,+DUZ(2),0))) S WVPOP=1
I '$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) D
.D NODCM^WVUTL9
.S WVPOP=1
.Q
I '$D(^RADPT) W !,"There is no Radiology/Nuclear Medicine Patient file (#70)",! S WVPOP=1
Q
DTRNG ; prompt for date range, go back three years maximum
S WVSTDT=DT-30000,WVSTDT=$$DATECHK(WVSTDT)
K DIR S DIR(0)="DA^"_WVSTDT_":"_DT
S DIR("A")="Enter START DATE: "
S DIR("?")="Enter the earliest date of the mammograms/ultrasounds you wish to retrieve. You can begin your search at "_$$FMTE^XLFDT(WVSTDT,"D")_"."
D ^DIR K DIR
I $D(DIRUT) S WVPOP=1 Q
S WVSTDT=Y
S DIR(0)="DA^"_WVSTDT_":"_DT
S DIR("A")="Enter END DATE: ",DIR("B")=$$FMTE^XLFDT(DT,"D")
S DIR("?")="Enter the most recent date of the mammograms/ultrasounds you wish to retrieve."
D ^DIR K DIR
I $D(DIRUT) S WVPOP=1 Q
S WVENDT=Y
Q
DATECHK(WVDATE) ; Check if WVDATE is a valid date. Substract 1 day until a
; valid date in WVDATE and return same.
N %DT,WVLOOP,X,Y
S Y=0
F WVLOOP=1:1 Q:Y>0 D
.S X=WVDATE,%DT=""
.D ^%DT
.Q:Y>0 ;valid date - stop checking
.S WVDATE=$$FMADD^XLFDT(WVDATE,-1)
.Q
Q WVDATE
;
STATUS ; Select default status for procedures
K DIR
S DIR(0)="S^o:OPEN;c:CLOSED",DIR("A")="Select STATUS OF IMPORTED MAMMOGRAMS"
S DIR("?")="Enter 'O' to give a Status of OPEN to Mammograms imported from the Radiology Software into the Women's Health database. Enter 'C' to give a Status of CLOSED to imported Mammograms."
D ^DIR K DIR
I $D(DIRUT) S WVPOP=1
S WVSTATUS=Y
Q
QUEUE ; Task as background job
S ZTIO="",ZTDESC="WH GRAB RAD/NM DATA",ZTRTN="EN2^WVEXPTRA"
S ZTDTH=$H,WVPOP=1
S ZTSAVE("WVENDT")="",ZTSAVE("WVSTDT")="",ZTSAVE("WVSTATUS")=""
S ZTSAVE("WVEC(")=""
D ^%ZTLOAD
Q
CPTS ; Loop through File 71 to get procedure pointers for the CPTs we
; are interested in.
N WVPROC,WVCPTS S WVIEN=0 K WVARRAY
D GETCPTS(.WVCPTS)
F S WVIEN=$O(^RAMIS(71,WVIEN)) Q:'WVIEN D
.S WVCPT=$$GET1^DIQ(71,WVIEN,9,"I") ;CPT code
.Q:WVCPT=""
.S WVPROC=0
.S WVPROC=$O(^WV(790.2,"AC",WVCPT,WVPROC))
.I 'WVPROC D
..S WVPROC=+$G(WVCPTS("CPT",WVCPT)) I WVPROC>0 Q
..S WVPROC=+$G(WVCPTS("RAD",WVIEN))
.Q:'WVPROC
.Q:$P($G(^WV(790.2,+WVPROC,0)),U,5)'="R"
.S WVARRAY(WVIEN)=""
Q
;
GETCPTS(WVCPTS) ;
N CODE,CODES,ERROR,RAD,TERMIEN,WVPROC,WVTERM
S TERMIEN=0 F S TERMIEN=$O(^WV(790.2,"RT",TERMIEN)) Q:TERMIEN'>0 D
.K CODES
.D GETTRMCD^PXRMPRAD(TERMIEN,.CODES,.WVTERM,.ERROR)
.S WVPROC=$O(^WV(790.2,"RT",TERMIEN,""))
.S CODE="" F S CODE=$O(CODES(CODE)) Q:CODE="" D
..S WVCPTS("CPT",CODE)=WVPROC
.S RAD="" F S RAD=$O(WVTERM("E","RAMIS(71,",RAD)) Q:RAD="" D
..S WVCPTS("RAD",RAD)=WVPROC
Q
;
GET ; get mammograms and ultrasounds from RAD/NM database
;---> WVMCNT = total new procedures added.
;---> WVNEWP = total new patients added.
N WVRPTSTA
S (WVMCNT,WVNEWP)=0
Q:'$D(WVARRAY) ;no mammogram or ultrasound procedures in File 71
S WVENDT=WVENDT\1,WVENDT=9999999-WVENDT ;inverse end date
S WVSTDT=WVSTDT\1,WVSTDT=9999999-WVSTDT ;inverse start date
S WVSTDT=WVSTDT_".9999"
S WVDFN=0 ;patient dfn
F S WVDFN=$O(^RADPT(WVDFN)) Q:'WVDFN D ;RAD/NM patient file
.Q:$P($G(^DPT(WVDFN,0)),U,2)'="F" ;not female
.Q:'$$VECCHK^WVGETAL1(WVDFN) ;failed vet/non-vet/eligibility code check
.S WVDTI=WVENDT ;Because the exam date is inverse the end date will
.; will be the lower value.
.F S WVDTI=$O(^RADPT(WVDFN,"DT",WVDTI)) Q:'WVDTI!(WVDTI>WVSTDT) D
..S WVCNI=0 ;case number
..F S WVCNI=$O(^RADPT(WVDFN,"DT",WVDTI,"P",WVCNI)) Q:'WVCNI D
...S WVNODE=$G(^RADPT(WVDFN,"DT",WVDTI,"P",WVCNI,0))
...Q:WVNODE=""
...S WVPROC=$P(WVNODE,U,2) ;procedure pointer
...Q:'WVPROC ;no pointer to File 71 (no procedure)
...Q:'$D(WVARRAY(WVPROC)) ;not a WH-related procedure
...S WVRPT=$P(WVNODE,U,17) ;report pointer
...Q:'WVRPT ;no pointer to File 74 (no report)
...S WVRPTSTA=$$GET1^DIQ(74,WVRPT,5,"I")
...I WVRPTSTA'="V"&(WVRPTSTA'="EE") Q ;report status, must be VERIFIED or ELECTRIONALLY ENTER
...D CREATEH^WVRALINK(WVDFN,WVDTI,WVCNI,WVSTATUS)
...Q
..Q
.Q
Q
MAIL ; send mail message to user with counts of procedures & patients added
N WVMSG,XMSUB,XMTEXT,XMY
S XMDUZ=.5 ;message sender
S XMY(DUZ)="" ;person who ran option
S XMSUB="Export of RAD/NM procedures to WH is done"
S WVMSG(1)=" # of New patients added to Women's Health package: "_WVNEWP
S WVMSG(2)="# of New procedures added to Women's Health package: "_WVMCNT
I '$D(WVARRAY) D
.S WVMSG(3)=" "
.S WVMSG(4)="There are no mammogram or ultrasound procedures listed in your"
.S WVMSG(5)="Radiology/Nuclear Medicine package."
.Q
S XMTEXT="WVMSG("
D ^XMD
I $D(ZTQUEUED) S ZTREQ="@"
Q
KILL ;
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
K WVARRAY,WVCNI,WVCPT,WVDFN,WVDTI,WVEC,WVENDT,WVIEN,WVMCNT,WVNEWP,WVNODE,WVPOP,WVPROC,WVRPT,WVSTATUS,WVSTDT
K X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVEXPTRA 6582 printed Apr 09, 2024@21:49:30 Page 2
WVEXPTRA ;HCIOFO/FT-EXPORT MAMS & ULTRASOUNDS TO WOMEN'S HEALTH ;04/15/2021
+1 ;;1.0;WOMEN'S HEALTH;**3,5,7,10,26**;Sep 30, 1998;Build 624
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;---> WVNEWP = TOTAL NEW WOMEN'S HEALTH PATIENTS ADDED.
+5 ;---> WVMAM = TOTAL NEW MAMMOGRAMS PROCEDURES ADDED.
+6 ;
EN1 ;
+1 SET WVPOP=0
SET WVEC=""
+2 ;check if site parameter entry exists
DO CHECK
IF WVPOP
DO KILL
QUIT
+3 ;describe option
DO DESC
+4 ;get date range
DO DTRNG
IF WVPOP
DO KILL
QUIT
+5 ;select status of procedure
DO STATUS
IF WVPOP
DO KILL
QUIT
+6 ;veterans/non-vets/eligibility code
DO EC^WVGETAL1
IF WVPOP
DO KILL
QUIT
+7 ;queue a background job
DO QUEUE
+8 DO KILL
+9 QUIT
EN2 ;
+1 ;get procedure pointers
DO CPTS
+2 ;get RAD/NM data & store in WH
DO GET
+3 ;send mail message to user
DO MAIL
+4 ;kill variables
DO KILL
+5 QUIT
DESC ; Describe option
+1 WRITE @IOF
+2 WRITE !,"This option searches the Radiology/Nuclear Medicine database for"
+3 WRITE !,"all female patients who had a mammogram, breast ultrasound, pelvic"
+4 WRITE !,"ultrasound or vaginal ultrasound exam during the date range you select."
+5 WRITE !,"These procedures and patients will be added to the WH database if"
+6 WRITE !,"not already there.",!
+7 WRITE !,"This job will be queued as a background task so as to free up your"
+8 WRITE !,"terminal to do other work. You will receive a mail message when"
+9 WRITE !,"the job is done. The mail message will contain a count of the"
+10 WRITE !,"number of procedures and patients added.",!!
+11 QUIT
CHECK ; Check if DUZ(2) exists for user, if entry exists in site parameter
+1 ; file, if case manager, and if File 70 exists.
+2 DO CHECK^WVLOGO
+3 IF '$GET(DUZ(2))!('$DATA(^WV(790.02,+DUZ(2),0)))
SET WVPOP=1
+4 IF '$PIECE($GET(^WV(790.02,+$GET(DUZ(2)),0)),U,2)
Begin DoDot:1
+5 DO NODCM^WVUTL9
+6 SET WVPOP=1
+7 QUIT
End DoDot:1
+8 IF '$DATA(^RADPT)
WRITE !,"There is no Radiology/Nuclear Medicine Patient file (#70)",!
SET WVPOP=1
+9 QUIT
DTRNG ; prompt for date range, go back three years maximum
+1 SET WVSTDT=DT-30000
SET WVSTDT=$$DATECHK(WVSTDT)
+2 KILL DIR
SET DIR(0)="DA^"_WVSTDT_":"_DT
+3 SET DIR("A")="Enter START DATE: "
+4 SET DIR("?")="Enter the earliest date of the mammograms/ultrasounds you wish to retrieve. You can begin your search at "_$$FMTE^XLFDT(WVSTDT,"D")_"."
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
SET WVPOP=1
QUIT
+7 SET WVSTDT=Y
+8 SET DIR(0)="DA^"_WVSTDT_":"_DT
+9 SET DIR("A")="Enter END DATE: "
SET DIR("B")=$$FMTE^XLFDT(DT,"D")
+10 SET DIR("?")="Enter the most recent date of the mammograms/ultrasounds you wish to retrieve."
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET WVPOP=1
QUIT
+13 SET WVENDT=Y
+14 QUIT
DATECHK(WVDATE) ; Check if WVDATE is a valid date. Substract 1 day until a
+1 ; valid date in WVDATE and return same.
+2 NEW %DT,WVLOOP,X,Y
+3 SET Y=0
+4 FOR WVLOOP=1:1
if Y>0
QUIT
Begin DoDot:1
+5 SET X=WVDATE
SET %DT=""
+6 DO ^%DT
+7 ;valid date - stop checking
if Y>0
QUIT
+8 SET WVDATE=$$FMADD^XLFDT(WVDATE,-1)
+9 QUIT
End DoDot:1
+10 QUIT WVDATE
+11 ;
STATUS ; Select default status for procedures
+1 KILL DIR
+2 SET DIR(0)="S^o:OPEN;c:CLOSED"
SET DIR("A")="Select STATUS OF IMPORTED MAMMOGRAMS"
+3 SET DIR("?")="Enter 'O' to give a Status of OPEN to Mammograms imported from the Radiology Software into the Women's Health database. Enter 'C' to give a Status of CLOSED to imported Mammograms."
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
SET WVPOP=1
+6 SET WVSTATUS=Y
+7 QUIT
QUEUE ; Task as background job
+1 SET ZTIO=""
SET ZTDESC="WH GRAB RAD/NM DATA"
SET ZTRTN="EN2^WVEXPTRA"
+2 SET ZTDTH=$HOROLOG
SET WVPOP=1
+3 SET ZTSAVE("WVENDT")=""
SET ZTSAVE("WVSTDT")=""
SET ZTSAVE("WVSTATUS")=""
+4 SET ZTSAVE("WVEC(")=""
+5 DO ^%ZTLOAD
+6 QUIT
CPTS ; Loop through File 71 to get procedure pointers for the CPTs we
+1 ; are interested in.
+2 NEW WVPROC,WVCPTS
SET WVIEN=0
KILL WVARRAY
+3 DO GETCPTS(.WVCPTS)
+4 FOR
SET WVIEN=$ORDER(^RAMIS(71,WVIEN))
if 'WVIEN
QUIT
Begin DoDot:1
+5 ;CPT code
SET WVCPT=$$GET1^DIQ(71,WVIEN,9,"I")
+6 if WVCPT=""
QUIT
+7 SET WVPROC=0
+8 SET WVPROC=$ORDER(^WV(790.2,"AC",WVCPT,WVPROC))
+9 IF 'WVPROC
Begin DoDot:2
+10 SET WVPROC=+$GET(WVCPTS("CPT",WVCPT))
IF WVPROC>0
QUIT
+11 SET WVPROC=+$GET(WVCPTS("RAD",WVIEN))
End DoDot:2
+12 if 'WVPROC
QUIT
+13 if $PIECE($GET(^WV(790.2,+WVPROC,0)),U,5)'="R"
QUIT
+14 SET WVARRAY(WVIEN)=""
End DoDot:1
+15 QUIT
+16 ;
GETCPTS(WVCPTS) ;
+1 NEW CODE,CODES,ERROR,RAD,TERMIEN,WVPROC,WVTERM
+2 SET TERMIEN=0
FOR
SET TERMIEN=$ORDER(^WV(790.2,"RT",TERMIEN))
if TERMIEN'>0
QUIT
Begin DoDot:1
+3 KILL CODES
+4 DO GETTRMCD^PXRMPRAD(TERMIEN,.CODES,.WVTERM,.ERROR)
+5 SET WVPROC=$ORDER(^WV(790.2,"RT",TERMIEN,""))
+6 SET CODE=""
FOR
SET CODE=$ORDER(CODES(CODE))
if CODE=""
QUIT
Begin DoDot:2
+7 SET WVCPTS("CPT",CODE)=WVPROC
End DoDot:2
+8 SET RAD=""
FOR
SET RAD=$ORDER(WVTERM("E","RAMIS(71,",RAD))
if RAD=""
QUIT
Begin DoDot:2
+9 SET WVCPTS("RAD",RAD)=WVPROC
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
GET ; get mammograms and ultrasounds from RAD/NM database
+1 ;---> WVMCNT = total new procedures added.
+2 ;---> WVNEWP = total new patients added.
+3 NEW WVRPTSTA
+4 SET (WVMCNT,WVNEWP)=0
+5 ;no mammogram or ultrasound procedures in File 71
if '$DATA(WVARRAY)
QUIT
+6 ;inverse end date
SET WVENDT=WVENDT\1
SET WVENDT=9999999-WVENDT
+7 ;inverse start date
SET WVSTDT=WVSTDT\1
SET WVSTDT=9999999-WVSTDT
+8 SET WVSTDT=WVSTDT_".9999"
+9 ;patient dfn
SET WVDFN=0
+10 ;RAD/NM patient file
FOR
SET WVDFN=$ORDER(^RADPT(WVDFN))
if 'WVDFN
QUIT
Begin DoDot:1
+11 ;not female
if $PIECE($GET(^DPT(WVDFN,0)),U,2)'="F"
QUIT
+12 ;failed vet/non-vet/eligibility code check
if '$$VECCHK^WVGETAL1(WVDFN)
QUIT
+13 ;Because the exam date is inverse the end date will
SET WVDTI=WVENDT
+14 ; will be the lower value.
+15 FOR
SET WVDTI=$ORDER(^RADPT(WVDFN,"DT",WVDTI))
if 'WVDTI!(WVDTI>WVSTDT)
QUIT
Begin DoDot:2
+16 ;case number
SET WVCNI=0
+17 FOR
SET WVCNI=$ORDER(^RADPT(WVDFN,"DT",WVDTI,"P",WVCNI))
if 'WVCNI
QUIT
Begin DoDot:3
+18 SET WVNODE=$GET(^RADPT(WVDFN,"DT",WVDTI,"P",WVCNI,0))
+19 if WVNODE=""
QUIT
+20 ;procedure pointer
SET WVPROC=$PIECE(WVNODE,U,2)
+21 ;no pointer to File 71 (no procedure)
if 'WVPROC
QUIT
+22 ;not a WH-related procedure
if '$DATA(WVARRAY(WVPROC))
QUIT
+23 ;report pointer
SET WVRPT=$PIECE(WVNODE,U,17)
+24 ;no pointer to File 74 (no report)
if 'WVRPT
QUIT
+25 SET WVRPTSTA=$$GET1^DIQ(74,WVRPT,5,"I")
+26 ;report status, must be VERIFIED or ELECTRIONALLY ENTER
IF WVRPTSTA'="V"&(WVRPTSTA'="EE")
QUIT
+27 DO CREATEH^WVRALINK(WVDFN,WVDTI,WVCNI,WVSTATUS)
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 QUIT
MAIL ; send mail message to user with counts of procedures & patients added
+1 NEW WVMSG,XMSUB,XMTEXT,XMY
+2 ;message sender
SET XMDUZ=.5
+3 ;person who ran option
SET XMY(DUZ)=""
+4 SET XMSUB="Export of RAD/NM procedures to WH is done"
+5 SET WVMSG(1)=" # of New patients added to Women's Health package: "_WVNEWP
+6 SET WVMSG(2)="# of New procedures added to Women's Health package: "_WVMCNT
+7 IF '$DATA(WVARRAY)
Begin DoDot:1
+8 SET WVMSG(3)=" "
+9 SET WVMSG(4)="There are no mammogram or ultrasound procedures listed in your"
+10 SET WVMSG(5)="Radiology/Nuclear Medicine package."
+11 QUIT
End DoDot:1
+12 SET XMTEXT="WVMSG("
+13 DO ^XMD
+14 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+15 QUIT
KILL ;
+1 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+2 KILL WVARRAY,WVCNI,WVCPT,WVDFN,WVDTI,WVEC,WVENDT,WVIEN,WVMCNT,WVNEWP,WVNODE,WVPOP,WVPROC,WVRPT,WVSTATUS,WVSTDT
+3 KILL X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+4 QUIT
+5 ;
