BWMDE5 ;IHS/ANMC/MWR - AUTOEDIT OF DATE ENROLLED;12-Feb-2003 10:32;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; LOOP THROUGH BW PATIENT FILE, IF DATE ENROLLED IS NULL, STUFF
;; DATE OF FIRST PROCEDURE OR DATE FUNDING BEGAN.
;; ALSO EXAMINE EXPORTED RECORDS.
;
;---> USE THIS LOOP TO STUFF DATE ENROLLED FOR ALL PATIENTS.
D SETVARS^BWUTL5
S N=0,BWSTART=$P(^BWSITE(DUZ(2),0),U,17)
F S N=$O(^BWP(N)) Q:'N D ENROL(N,BWSTART) W "."
W !!?5,"Done."
Q
;
ENROL(DFN,BWSTART,BWY) ;EP
;---> BWSTART=DATE CDC FUNDING PROGRAM BEGAN.
;---> SET CDC ENROLLMENT DATE FOR THIS PATIENT.
;---> REQUIRED VARIABLES: DFN=PATIENT DFN
; BWSTART=START DATE OF CDC FUNDING
; BWY=RETURNED AS ENROL DATE FOR THIS PATIENT
N BWTMP,IEN,Y S BWY=0
Q:'$D(^BWP(DFN,0))
S Y=^BWP(DFN,0)
;---> QUIT IF THIS PATIENT ALREADY HAS A DATE ENROLLED.
Q:$P(Y,U,21)
;---> QUIT IF THIS PATIENT HAS NO PROCEDURES ON RECORD.
I '$D(^BWPCD("C",DFN)) S $P(^BWP(DFN,0),U,21)="" Q
;---> GATHER THIS PATIENT'S PROCEDURES IN BWTMP BY DATE.
S IEN=0
F S IEN=$O(^BWPCD("C",DFN,IEN)) Q:'IEN D
.S BWTMP($P(^BWPCD(IEN,0),U,12))=""
;---> NOW GET EARLIEST PROCEDURE. IF THAT POST-DATES CDC FUNDING
;---> START DATE FOR THIS SITE, SET ENROLLMENT DATE EQUAL TO IT.
;---> IF EARLIEST PROCEDURE PRE-DATES CDC START DATE, THEN SET
;---> ENROLLMENT DATE EQUAL TO CDC START DATE.
I $D(BWTMP) D Q
.N X S X=$O(BWTMP(BWSTART))
.I 'X D EDIT(DFN,BWSTART,.BWY) Q
.D EDIT(DFN,X,.BWY)
Q
;
EDIT(DFN,DATE,BWY) ;EP
;---> ENTER DATE INTO FIELD #.21 DATE ENROLLED.
N (BWY,DATE,DFN,DT,DTIME,DUZ,U) D SETVARS^BWUTL5
S:$E(DATE,6,7)="00" $E(DATE,6,7)="01"
S DR=".21////"_DATE,BWY=DATE
D DIE^BWFMAN(9002086,DR,DFN,.BWPOP)
Q
;
;
EXAMINE ;EP
;---> PROGRAMMER UTILITY; NOT CALLED BY ANY USER OPTION.
;---> EXAMINE FIXED BWLENGTH MDE RECORDS TO BE EXPORTED TO CDC,
;---> STORE IN ^BWTMP.
;
N DFN,I,J,N,Y
D SETVARS^BWUTL5 S BWPOP=0
R:DTIME !!,"$J: ",J
Q:'J
F D Q:BWPOP
.R:DTIME !!,"DFN: ",DFN
.I DFN="" S BWPOP=1 Q
.I '$D(^BWTMP(J,DFN)) W !,"DOES NOT EXIST",! Q
.S N=0
.F S N=$O(^BWTMP(J,DFN,N)) Q:'N D Q:BWPOP
..S BWY=^BWTMP(J,DFN,N)
..W !!,"RECORD ($J,DFN,IEN): ^BWTMP(",J,",",DFN,",",N
..W " PATIENT: ",$$NAME^BWUTL1(DFN)
..W !,"-------------------------------------------------------------"
..S Y=0,I=0
..F S Y=$O(^BWMDE(Y)) D:'Y DIRZ^BWUTL3 Q:'Y D Q:BWPOP
...;S DIC(0)="QEMA",DIC=9002086.91,DIC("A")=" Select FIELD: "
...;D ^DIC K DIC
...;I Y<0 S BWPOP1=1 Q
...S NODE=^BWMDE(+Y,0)
...I I>15 D DIRZ^BWUTL3 S I=0
...Q:BWPOP
...S BWCOLEN=$P(NODE,U,3)
...S BWCOL=$P(BWCOLEN,","),BWLEN=$P(BWCOLEN,",",2)
...S BWVAL=$E(BWY,BWCOL,BWCOL+(BWLEN-1))
...I BWVAL?.N.A&(BWVAL]"") W !,$P(NODE,U),?40,BWVAL S I=I+1
D KILLALL^BWUTL8
Q
BWMDE5 ;IHS/ANMC/MWR - AUTOEDIT OF DATE ENROLLED;12-Feb-2003 10:32;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; LOOP THROUGH BW PATIENT FILE, IF DATE ENROLLED IS NULL, STUFF
+4 ;; DATE OF FIRST PROCEDURE OR DATE FUNDING BEGAN.
+5 ;; ALSO EXAMINE EXPORTED RECORDS.
+6 ;
+7 ;---> USE THIS LOOP TO STUFF DATE ENROLLED FOR ALL PATIENTS.
+8 DO SETVARS^BWUTL5
+9 SET N=0
SET BWSTART=$PIECE(^BWSITE(DUZ(2),0),U,17)
+10 FOR
SET N=$ORDER(^BWP(N))
IF 'N
QUIT
DO ENROL(N,BWSTART)
WRITE "."
+11 WRITE !!?5,"Done."
+12 QUIT
+13 ;
ENROL(DFN,BWSTART,BWY) ;EP
+1 ;---> BWSTART=DATE CDC FUNDING PROGRAM BEGAN.
+2 ;---> SET CDC ENROLLMENT DATE FOR THIS PATIENT.
+3 ;---> REQUIRED VARIABLES: DFN=PATIENT DFN
+4 ; BWSTART=START DATE OF CDC FUNDING
+5 ; BWY=RETURNED AS ENROL DATE FOR THIS PATIENT
+6 NEW BWTMP,IEN,Y
SET BWY=0
+7 IF '$DATA(^BWP(DFN,0))
QUIT
+8 SET Y=^BWP(DFN,0)
+9 ;---> QUIT IF THIS PATIENT ALREADY HAS A DATE ENROLLED.
+10 IF $PIECE(Y,U,21)
QUIT
+11 ;---> QUIT IF THIS PATIENT HAS NO PROCEDURES ON RECORD.
+12 IF '$DATA(^BWPCD("C",DFN))
SET $PIECE(^BWP(DFN,0),U,21)=""
QUIT
+13 ;---> GATHER THIS PATIENT'S PROCEDURES IN BWTMP BY DATE.
+14 SET IEN=0
+15 FOR
SET IEN=$ORDER(^BWPCD("C",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+16 SET BWTMP($PIECE(^BWPCD(IEN,0),U,12))=""
End DoDot:1
+17 ;---> NOW GET EARLIEST PROCEDURE. IF THAT POST-DATES CDC FUNDING
+18 ;---> START DATE FOR THIS SITE, SET ENROLLMENT DATE EQUAL TO IT.
+19 ;---> IF EARLIEST PROCEDURE PRE-DATES CDC START DATE, THEN SET
+20 ;---> ENROLLMENT DATE EQUAL TO CDC START DATE.
+21 IF $DATA(BWTMP)
Begin DoDot:1
+22 NEW X
SET X=$ORDER(BWTMP(BWSTART))
+23 IF 'X
DO EDIT(DFN,BWSTART,.BWY)
QUIT
+24 DO EDIT(DFN,X,.BWY)
End DoDot:1
QUIT
+25 QUIT
+26 ;
EDIT(DFN,DATE,BWY) ;EP
+1 ;---> ENTER DATE INTO FIELD #.21 DATE ENROLLED.
+2 NEW (BWY,DATE,DFN,DT,DTIME,DUZ,U)
DO SETVARS^BWUTL5
+3 IF $EXTRACT(DATE,6,7)="00"
SET $EXTRACT(DATE,6,7)="01"
+4 SET DR=".21////"_DATE
SET BWY=DATE
+5 DO DIE^BWFMAN(9002086,DR,DFN,.BWPOP)
+6 QUIT
+7 ;
+8 ;
EXAMINE ;EP
+1 ;---> PROGRAMMER UTILITY; NOT CALLED BY ANY USER OPTION.
+2 ;---> EXAMINE FIXED BWLENGTH MDE RECORDS TO BE EXPORTED TO CDC,
+3 ;---> STORE IN ^BWTMP.
+4 ;
+5 NEW DFN,I,J,N,Y
+6 DO SETVARS^BWUTL5
SET BWPOP=0
+7 IF DTIME
READ !!,"$J: ",J
+8 IF 'J
QUIT
+9 FOR
Begin DoDot:1
+10 IF DTIME
READ !!,"DFN: ",DFN
+11 IF DFN=""
SET BWPOP=1
QUIT
+12 IF '$DATA(^BWTMP(J,DFN))
WRITE !,"DOES NOT EXIST",!
QUIT
+13 SET N=0
+14 FOR
SET N=$ORDER(^BWTMP(J,DFN,N))
IF 'N
QUIT
Begin DoDot:2
+15 SET BWY=^BWTMP(J,DFN,N)
+16 WRITE !!,"RECORD ($J,DFN,IEN): ^BWTMP(",J,",",DFN,",",N
+17 WRITE " PATIENT: ",$$NAME^BWUTL1(DFN)
+18 WRITE !,"-------------------------------------------------------------"
+19 SET Y=0
SET I=0
+20 FOR
SET Y=$ORDER(^BWMDE(Y))
IF 'Y
DO DIRZ^BWUTL3
IF 'Y
QUIT
Begin DoDot:3
+21 ;S DIC(0)="QEMA",DIC=9002086.91,DIC("A")=" Select FIELD: "
+22 ;D ^DIC K DIC
+23 ;I Y<0 S BWPOP1=1 Q
+24 SET NODE=^BWMDE(+Y,0)
+25 IF I>15
DO DIRZ^BWUTL3
SET I=0
+26 IF BWPOP
QUIT
+27 SET BWCOLEN=$PIECE(NODE,U,3)
+28 SET BWCOL=$PIECE(BWCOLEN,",")
SET BWLEN=$PIECE(BWCOLEN,",",2)
+29 SET BWVAL=$EXTRACT(BWY,BWCOL,BWCOL+(BWLEN-1))
+30 IF BWVAL?.N.A&(BWVAL]"")
WRITE !,$PIECE(NODE,U),?40,BWVAL
SET I=I+1
End DoDot:3
IF BWPOP
QUIT
End DoDot:2
IF BWPOP
QUIT
End DoDot:1
IF BWPOP
QUIT
+31 DO KILLALL^BWUTL8
+32 QUIT
