WVEXPTRA.m

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 ---WVEXPTRA   6582     printed  Apr 23, 2025@19:01:26                                                                                                                                                                                                    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       ;