Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWMDE5

BWMDE5.m

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