WV1026P ;ISP/AGP - PATCH 26 INSTALLATION TASKS;Feb 01, 2021@15:37
;;1.0;WOMEN'S HEALTH;**26**;Sep 30, 1998;Build 624
Q
;
BLDARRAY(ARRAY) ;
S ARRAY("BR 0 BIOPSY ALREADY OBTAIN")="BREAST BIOPSY ALREADY OBTAIN"
S ARRAY("BR BIRAD 0 CONSULT")="BREAST CONSULT"
S ARRAY("BR 0 CURRENTLY UNDER TREATMENT")="BREAST CURRENTLY UNDER TREATMENT"
S ARRAY("BR BIRAD 1, need Mammogram")="BREAST NEED MAMMOGRAM"
S ARRAY("BR BIRAD 1, need MRI")="BREAST NEED MRI"
S ARRAY("BR BIRAD 1, need Ultrasound")="BREAST NEED ULTRASOUND"
S ARRAY("BR BIRAD 0 OBTAIN PRIOR FILMS")="BREAST OBTAIN PRIOR FILMS"
S ARRAY("BR 0 REFER FOR BIOPSY")="BREAST REFER FOR BIOPSY"
S ARRAY("BR 0 REFER TO ONCOLOGIST")="BREAST REFER TO ONCOLOGIST"
S ARRAY("BR 0 REFER TO SURGEON")="BREAST REFER TO SURGEON"
;S ARRAY("BR BIRAD 1, next MAM AGE AT START AGE")="BR BIRAD 1, next MAM AT START AGE"
;S ARRAY("BR BIRAD 2, next MAM AGE AT START AGE")="BR BIRAD 2, next MAM AT START AGE"
S ARRAY("BR BIRAD 1, next MAM AGE 1Y")="BREAST next MAM 1Y"
S ARRAY("BR BIRAD 1, next MAM AGE 2Y")="BREAST next MAM 2Y"
S ARRAY("BR BIRAD 1, next MAM AT START AGE")="BREAST next MAM AT START AGE"
Q
GETLIST(ARRAY,WHAT) ;
N LINE
I WHAT="PURPOSE" D Q
.F LINE=1:1 Q:$L($T(PURLIST+LINE))<3 D
..N TEXT
..S TEXT=$P($T(PURLIST+LINE),";;",2)
..S ARRAY(TEXT)=""
Q
;
PATDATES ;
N ARRAY,ACTNODE,IEN,NAME,NODE,NOTE,PATS,PROC,WVFUDATE,WVFDA,WVERR,WVIEN
D BMES^XPDUTL("Update Women's Health Patient record that need Next Breast Treatment Date")
D BMES^XPDUTL(" Find Procedure to review")
S IEN=$O(^WV(790.51,"B","Mammogram, Screening",""))
I IEN>0 S ARRAY(IEN)=""
S IEN=$O(^WV(790.51,"B","BREAST TOMOSYNTHESIS SCREENING",""))
I IEN>0 S ARRAY(IEN)=""
I '$D(ARRAY) Q
;find patients that need to be reviewed
D BMES^XPDUTL(" Find Patients to review")
S NOTE="" F S NOTE=$O(^WV(790.1,"NOTE",NOTE)) Q:NOTE="" D
.S WVIEN=0 F S WVIEN=$O(^WV(790.1,"NOTE",NOTE,WVIEN)) Q:WVIEN'>0 D
..S NODE=$G(^WV(790.1,WVIEN,0))
..S IEN=0
..F S IEN=$O(^WV(790.1,WVIEN,10,IEN)) Q:IEN'>0 D
...S ACTNODE=$G(^WV(790.1,WVIEN,10,IEN,0))
...I $P(ACTNODE,U,5)="Y" Q
...I $P(ACTNODE,U)'="Return to Age Based Screening" Q
...S PATS(+$P(NODE,U,2))=""
;loop through patients for review
D BMES^XPDUTL(" Review Patients record")
S IEN=0 F S IEN=$O(PATS(IEN)) Q:IEN'>0 D
.I '$$UNDERAGE(IEN) Q
.S NODE=$G(^WV(790,IEN,0))
.S PROC=$P(NODE,U,18) I +PROC=0 Q
.I '$D(ARRAY(PROC)) Q
.I +$P(NODE,U,19)>0 Q
.S NAME=$$GET1^DIQ(2,IEN,.01)
.I NAME="" Q
.S WVFUDATE=""
.D TERMEVAL^WVRPCGF2(IEN,.WVFUDATE)
.I WVFUDATE="" Q
.D BMES^XPDUTL(" Updating patient "_NAME)
.S WVFDA(790,IEN_",",.19)=WVFUDATE
.D FILE^DIE("","WVFDA","WVERR")
.I $D(WVERR) D
..D BMES^XPDUTL(" Error updating record")
..D AWRITE^PXRMUTIL("WVERR")
Q
;
PRE ;
N WVMSG
S WVMSG(1)=" Removing the data dictionary for the "
S WVMSG(2)=" WV PREGNANCY/LACTATION STATUS CONFLICT EVENTS file (#790.9)..."
D BMES^XPDUTL(.WVMSG)
N DIU
S DIU=790.9,DIU(0)=""
D EN^DIU2
D MES^XPDUTL(" DONE")
Q
POST ;
D RENAME,PATDATES,REINDEX,CLEAR
Q
;
RENAME ;
N ARRAY,NAME,NEWNAME
D BLDARRAY(.ARRAY)
S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
.S NEWNAME=ARRAY(NAME)
.D RENAME^PXRMUTIL(790.404,NAME,NEWNAME)
Q
;
UNDERAGE(DFN) ;
N AGE,DOB
I +$P($G(^DPT(DFN,.35)),U,1)>0 Q 0
S DOB=$P(^DPT(DFN,0),U,3)
S AGE=(DT-DOB)\10000
I AGE>44 Q 0
Q 1
;
SENDPUR(ANAME) ;
N ARRAY
D GETLIST(.ARRAY,"PURPOSE")
I $D(ARRAY(ANAME)) Q 1
Q 0
;
REINDEX ; Rebuild the APREG index in the WV PATIENT file (#790)
D BMES^XPDUTL(" Rebuilding the APREG index...")
N WVDFN
S WVDFN=0 F S WVDFN=$O(^WV(790,WVDFN)) Q:'+WVDFN D
.N WVINDEX
.K ^WV(790,WVDFN,4,"APREG")
.D PREGS^WVUTL11(WVDFN,.WVINDEX)
D MES^XPDUTL(" DONE")
Q
;
CLEAR ; Clear the Cover Sheet data cache for all patients
D BMES^XPDUTL(" Clearing the CPRS Cover Sheet data cache...")
N WVSUB
S WVSUB="WV_CCS;" F S WVSUB=$O(^XTMP(WVSUB)) Q:$E(WVSUB,1,7)'="WV_CCS;" D
.K ^XTMP(WVSUB)
D MES^XPDUTL(" DONE")
Q
;
PURLIST ;
;;BI-RAD 0 DENSE RESULT
;;BI-RAD 0 RESULT
;;BI-RAD 1 DENSE RESULT
;;BI-RAD 1 RESULT
;;BI-RAD 2 DENSE RESULT
;;BI-RAD 2 RESULT
;;BI-RAD 3 DENSE RESULT
;;BI-RAD 3 RESULT
;;BI-RAD 4 DENSE RESULT
;;BI-RAD 4 RESULT
;;BI-RAD 5 DENSE RESULT
;;BI-RAD 5 RESULT
;;BI-RAD 6 DENSE RESULT
;;BI-RAD 6 RESULT
;;BREAST ABNORMAL DENSE RESULT
;;BREAST ABNORMAL RESULT
;;BREAST NORMAL DENSE RESULT
;;BREAST NORMAL RESULT
;;BREAST UNSATISFACTORY DENSE RESULT
;;BREAST UNSATISFACTORY RESULT
;;BREAST NEED MAMMOGRAM
;;BREAST NEED MRI
;;BREAST NEED ULTRASOUND
;;BREAST next MAM AT START AGE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWV1026P 4754 printed Dec 13, 2024@02:46:21 Page 2
WV1026P ;ISP/AGP - PATCH 26 INSTALLATION TASKS;Feb 01, 2021@15:37
+1 ;;1.0;WOMEN'S HEALTH;**26**;Sep 30, 1998;Build 624
+2 QUIT
+3 ;
BLDARRAY(ARRAY) ;
+1 SET ARRAY("BR 0 BIOPSY ALREADY OBTAIN")="BREAST BIOPSY ALREADY OBTAIN"
+2 SET ARRAY("BR BIRAD 0 CONSULT")="BREAST CONSULT"
+3 SET ARRAY("BR 0 CURRENTLY UNDER TREATMENT")="BREAST CURRENTLY UNDER TREATMENT"
+4 SET ARRAY("BR BIRAD 1, need Mammogram")="BREAST NEED MAMMOGRAM"
+5 SET ARRAY("BR BIRAD 1, need MRI")="BREAST NEED MRI"
+6 SET ARRAY("BR BIRAD 1, need Ultrasound")="BREAST NEED ULTRASOUND"
+7 SET ARRAY("BR BIRAD 0 OBTAIN PRIOR FILMS")="BREAST OBTAIN PRIOR FILMS"
+8 SET ARRAY("BR 0 REFER FOR BIOPSY")="BREAST REFER FOR BIOPSY"
+9 SET ARRAY("BR 0 REFER TO ONCOLOGIST")="BREAST REFER TO ONCOLOGIST"
+10 SET ARRAY("BR 0 REFER TO SURGEON")="BREAST REFER TO SURGEON"
+11 ;S ARRAY("BR BIRAD 1, next MAM AGE AT START AGE")="BR BIRAD 1, next MAM AT START AGE"
+12 ;S ARRAY("BR BIRAD 2, next MAM AGE AT START AGE")="BR BIRAD 2, next MAM AT START AGE"
+13 SET ARRAY("BR BIRAD 1, next MAM AGE 1Y")="BREAST next MAM 1Y"
+14 SET ARRAY("BR BIRAD 1, next MAM AGE 2Y")="BREAST next MAM 2Y"
+15 SET ARRAY("BR BIRAD 1, next MAM AT START AGE")="BREAST next MAM AT START AGE"
+16 QUIT
GETLIST(ARRAY,WHAT) ;
+1 NEW LINE
+2 IF WHAT="PURPOSE"
Begin DoDot:1
+3 FOR LINE=1:1
if $LENGTH($TEXT(PURLIST+LINE))<3
QUIT
Begin DoDot:2
+4 NEW TEXT
+5 SET TEXT=$PIECE($TEXT(PURLIST+LINE),";;",2)
+6 SET ARRAY(TEXT)=""
End DoDot:2
End DoDot:1
QUIT
+7 QUIT
+8 ;
PATDATES ;
+1 NEW ARRAY,ACTNODE,IEN,NAME,NODE,NOTE,PATS,PROC,WVFUDATE,WVFDA,WVERR,WVIEN
+2 DO BMES^XPDUTL("Update Women's Health Patient record that need Next Breast Treatment Date")
+3 DO BMES^XPDUTL(" Find Procedure to review")
+4 SET IEN=$ORDER(^WV(790.51,"B","Mammogram, Screening",""))
+5 IF IEN>0
SET ARRAY(IEN)=""
+6 SET IEN=$ORDER(^WV(790.51,"B","BREAST TOMOSYNTHESIS SCREENING",""))
+7 IF IEN>0
SET ARRAY(IEN)=""
+8 IF '$DATA(ARRAY)
QUIT
+9 ;find patients that need to be reviewed
+10 DO BMES^XPDUTL(" Find Patients to review")
+11 SET NOTE=""
FOR
SET NOTE=$ORDER(^WV(790.1,"NOTE",NOTE))
if NOTE=""
QUIT
Begin DoDot:1
+12 SET WVIEN=0
FOR
SET WVIEN=$ORDER(^WV(790.1,"NOTE",NOTE,WVIEN))
if WVIEN'>0
QUIT
Begin DoDot:2
+13 SET NODE=$GET(^WV(790.1,WVIEN,0))
+14 SET IEN=0
+15 FOR
SET IEN=$ORDER(^WV(790.1,WVIEN,10,IEN))
if IEN'>0
QUIT
Begin DoDot:3
+16 SET ACTNODE=$GET(^WV(790.1,WVIEN,10,IEN,0))
+17 IF $PIECE(ACTNODE,U,5)="Y"
QUIT
+18 IF $PIECE(ACTNODE,U)'="Return to Age Based Screening"
QUIT
+19 SET PATS(+$PIECE(NODE,U,2))=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;loop through patients for review
+21 DO BMES^XPDUTL(" Review Patients record")
+22 SET IEN=0
FOR
SET IEN=$ORDER(PATS(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+23 IF '$$UNDERAGE(IEN)
QUIT
+24 SET NODE=$GET(^WV(790,IEN,0))
+25 SET PROC=$PIECE(NODE,U,18)
IF +PROC=0
QUIT
+26 IF '$DATA(ARRAY(PROC))
QUIT
+27 IF +$PIECE(NODE,U,19)>0
QUIT
+28 SET NAME=$$GET1^DIQ(2,IEN,.01)
+29 IF NAME=""
QUIT
+30 SET WVFUDATE=""
+31 DO TERMEVAL^WVRPCGF2(IEN,.WVFUDATE)
+32 IF WVFUDATE=""
QUIT
+33 DO BMES^XPDUTL(" Updating patient "_NAME)
+34 SET WVFDA(790,IEN_",",.19)=WVFUDATE
+35 DO FILE^DIE("","WVFDA","WVERR")
+36 IF $DATA(WVERR)
Begin DoDot:2
+37 DO BMES^XPDUTL(" Error updating record")
+38 DO AWRITE^PXRMUTIL("WVERR")
End DoDot:2
End DoDot:1
+39 QUIT
+40 ;
PRE ;
+1 NEW WVMSG
+2 SET WVMSG(1)=" Removing the data dictionary for the "
+3 SET WVMSG(2)=" WV PREGNANCY/LACTATION STATUS CONFLICT EVENTS file (#790.9)..."
+4 DO BMES^XPDUTL(.WVMSG)
+5 NEW DIU
+6 SET DIU=790.9
SET DIU(0)=""
+7 DO EN^DIU2
+8 DO MES^XPDUTL(" DONE")
+9 QUIT
POST ;
+1 DO RENAME
DO PATDATES
DO REINDEX
DO CLEAR
+2 QUIT
+3 ;
RENAME ;
+1 NEW ARRAY,NAME,NEWNAME
+2 DO BLDARRAY(.ARRAY)
+3 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
Begin DoDot:1
+4 SET NEWNAME=ARRAY(NAME)
+5 DO RENAME^PXRMUTIL(790.404,NAME,NEWNAME)
End DoDot:1
+6 QUIT
+7 ;
UNDERAGE(DFN) ;
+1 NEW AGE,DOB
+2 IF +$PIECE($GET(^DPT(DFN,.35)),U,1)>0
QUIT 0
+3 SET DOB=$PIECE(^DPT(DFN,0),U,3)
+4 SET AGE=(DT-DOB)\10000
+5 IF AGE>44
QUIT 0
+6 QUIT 1
+7 ;
SENDPUR(ANAME) ;
+1 NEW ARRAY
+2 DO GETLIST(.ARRAY,"PURPOSE")
+3 IF $DATA(ARRAY(ANAME))
QUIT 1
+4 QUIT 0
+5 ;
REINDEX ; Rebuild the APREG index in the WV PATIENT file (#790)
+1 DO BMES^XPDUTL(" Rebuilding the APREG index...")
+2 NEW WVDFN
+3 SET WVDFN=0
FOR
SET WVDFN=$ORDER(^WV(790,WVDFN))
if '+WVDFN
QUIT
Begin DoDot:1
+4 NEW WVINDEX
+5 KILL ^WV(790,WVDFN,4,"APREG")
+6 DO PREGS^WVUTL11(WVDFN,.WVINDEX)
End DoDot:1
+7 DO MES^XPDUTL(" DONE")
+8 QUIT
+9 ;
CLEAR ; Clear the Cover Sheet data cache for all patients
+1 DO BMES^XPDUTL(" Clearing the CPRS Cover Sheet data cache...")
+2 NEW WVSUB
+3 SET WVSUB="WV_CCS;"
FOR
SET WVSUB=$ORDER(^XTMP(WVSUB))
if $EXTRACT(WVSUB,1,7)'="WV_CCS;"
QUIT
Begin DoDot:1
+4 KILL ^XTMP(WVSUB)
End DoDot:1
+5 DO MES^XPDUTL(" DONE")
+6 QUIT
+7 ;
PURLIST ;
+1 ;;BI-RAD 0 DENSE RESULT
+2 ;;BI-RAD 0 RESULT
+3 ;;BI-RAD 1 DENSE RESULT
+4 ;;BI-RAD 1 RESULT
+5 ;;BI-RAD 2 DENSE RESULT
+6 ;;BI-RAD 2 RESULT
+7 ;;BI-RAD 3 DENSE RESULT
+8 ;;BI-RAD 3 RESULT
+9 ;;BI-RAD 4 DENSE RESULT
+10 ;;BI-RAD 4 RESULT
+11 ;;BI-RAD 5 DENSE RESULT
+12 ;;BI-RAD 5 RESULT
+13 ;;BI-RAD 6 DENSE RESULT
+14 ;;BI-RAD 6 RESULT
+15 ;;BREAST ABNORMAL DENSE RESULT
+16 ;;BREAST ABNORMAL RESULT
+17 ;;BREAST NORMAL DENSE RESULT
+18 ;;BREAST NORMAL RESULT
+19 ;;BREAST UNSATISFACTORY DENSE RESULT
+20 ;;BREAST UNSATISFACTORY RESULT
+21 ;;BREAST NEED MAMMOGRAM
+22 ;;BREAST NEED MRI
+23 ;;BREAST NEED ULTRASOUND
+24 ;;BREAST next MAM AT START AGE
+25 QUIT
+26 ;
