CIMSNCID ; CMI/TUCSON/LAB -NCI STUDY ; [ 06/09/98 6:56 AM ]
;;1.0;NCI STUDY EXTRACT 1.0;;MAY 14, 1998
;
START ;
W:$D(IOF) @IOF
W !,$$CTR($$LOC(),80),!
S X="***** NCI CANCER STUDY *****" W !,$$CTR(X,80)
S X="Patterns of Care Among Native American Cancer Patients" W !,$$CTR(X,80),!
S T="INTRO" F J=1:1 S X=$T(@T+J),X=$P(X,";;",2) Q:X="END" W !,X
K J,X,T
W !,"There are " S X=0,C=0 F S X=$O(^CIMSCPAT(X)) Q:X'=+X S C=C+1
W C," patients in the NCI Cancer Study Register.",!
;
YEARS ;
S CIMSYRS=0
S DIR(0)="N^1:99:0",DIR("A")="How many years of data should be downloaded",DIR("B")="1" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) EOJ
S CIMSYRS=Y
CONT ;
S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR
I Y'=1 D EOJ Q
I $D(DIRUT) D EOJ Q
QUEUE ;EP
K ZTSK
S DIR(0)="Y",DIR("A")="Do you want to QUEUE this to run at a later time",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y=1 D EOJ,QUEUE1 Q
I $D(DIRUT) D EOJ Q
D PROC
Q
QUEUE1 ;
S ZTRTN="PROC^CIMSNCID"
S ZTIO="",ZTDTH="",ZTDESC="NCI STUDY EXPORT SYSTEM" S ZTSAVE("CIM*")=""
D ^%ZTLOAD
W !!,$S($D(ZTSK):"Request Queued.",1:"Request cancelled.")
I '$D(ZTSK) S Q=99 Q
K ZTSK
Q
PROC ;EP - called from xbdbque to process patients
I '$D(ZTQUEUED) W !,"Processing patients"
S CIMSH=$H,CIMSJ=$J,(CIMSA,CIMSB,CIMSC,CIMSD,CIMSE)=0
K ^TMP("CIMSNCI",$J,CIMSJ,CIMSH)
S DFN=0 F S DFN=$O(^CIMSCPAT(DFN)) Q:DFN'=+DFN S CIMSDDX=$P(^CIMSCPAT(DFN,0),U,4) D
.W:'$D(ZTQUEUED) "." D GENA
.D GENB
.D GENE
.Q
WRITEF ;write out flat file
A ;
W:'$D(ZTQUEUED) !!,"Writing out file A"
S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S CIMSJD=X+1
K ^TMP($J) S X=0 F S X=$O(^TMP("CIMSNCI",$J,"A",X)) Q:X'=+X S ^TMP($J,X)=^TMP("CIMSNCI",$J,"A",X)
S XBGL="TMP("_$J_","
S F="ncifilea."_CIMSJD
S XBMED="F",XBFN=F,XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
B ;
W:'$D(ZTQUEUED) !!,"Writing out file B"
K ^TMP($J) S X=0 F S X=$O(^TMP("CIMSNCI",$J,"B",X)) Q:X'=+X S ^TMP($J,X)=^TMP("CIMSNCI",$J,"B",X)
S XBGL="TMP("_$J_",",F="ncifileb."_CIMSJD,XBMED="F",XBFN=F,XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
C ;
W:'$D(ZTQUEUED) !!,"Writing out file C"
K ^TMP($J) S X=0 F S X=$O(^TMP("CIMSNCI",$J,"C",X)) Q:X'=+X S ^TMP($J,X)=^TMP("CIMSNCI",$J,"C",X)
S XBGL="TMP("_$J_",",F="ncifilec."_CIMSJD,XBMED="F",XBFN=F,XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
D ;
W:'$D(ZTQUEUED) !!,"Writing out file D"
K ^TMP($J) S X=0 F S X=$O(^TMP("CIMSNCI",$J,"D",X)) Q:X'=+X S ^TMP($J,X)=^TMP("CIMSNCI",$J,"D",X)
S XBGL="TMP("_$J_",",F="ncifiled."_CIMSJD,XBMED="F",XBFN=F,XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
E ;
W:'$D(ZTQUEUED) !!,"Writing out file E"
K ^TMP($J) S X=0 F S X=$O(^TMP("CIMSNCI",$J,"E",X)) Q:X'=+X S ^TMP($J,X)=^TMP("CIMSNCI",$J,"E",X)
S XBGL="TMP("_$J_",",F="ncifilee."_CIMSJD,XBMED="F",XBFN=F,XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
K ^TMP("CIMSNCI",$J)
K ^TMP($J)
K XBGL,XBMED,XBTLE,XBFN,XBF,XBQ,XBFLT
D EOJ
Q
GENA ;generate file a record
S X=$$AREC^CIMSNCI1(DFN,CIMSDDX,"NCI RECORD A")
S CIMSA=CIMSA+1
S ^TMP("CIMSNCI",$J,"A",CIMSA)=X
Q
GENB ;
;go through all visits 1 year prior to 1 year after cimsddx
Q:CIMSDDX=""
S CIMSBG=$$FMADD^XLFDT(CIMSDDX,(-365.25*CIMSYRS)),CIMSED=$$FMADD^XLFDT(CIMSDDX,(365.25*CIMSYRS))
S CIMVSIT=0 F S CIMVSIT=$O(^AUPNVSIT("AC",DFN,CIMVSIT)) Q:CIMVSIT'=+CIMVSIT D
.S D=$P($P(^AUPNVSIT(CIMVSIT,0),U),".")
.Q:D<CIMSBG
.Q:D>CIMSED
.Q:$P(^AUPNVSIT(CIMVSIT,0),U,11)
.Q:'$P(^AUPNVSIT(CIMVSIT,0),U,9)
.Q:"AH"'[$P(^AUPNVSIT(CIMVSIT,0),U,7)
.;Q:'$D(^AUPNVPOV("AD",CIMVSIT))
.;Q:'$D(^AUPNVPRV("AD",CIMVSIT))
.Q:$P(^AUPNVSIT(CIMVSIT,0),U,6)'=DUZ(2)
.I $D(^AUPNVPOV("AD",CIMVSIT)),$D(^AUPNVPRV("AD",CIMVSIT)) D
..S X=$$BREC^CIMSNCI1(CIMVSIT,"NCI RECORD B")
..S CIMSB=CIMSB+1
..S ^TMP("CIMSNCI",$J,"B",CIMSB)=X
.;DO GENERATE C RECORDS
.S CIMSLAB=0 F S CIMSLAB=$O(^AUPNVLAB("AD",CIMVSIT,CIMSLAB)) Q:CIMSLAB'=+CIMSLAB D
..S X=$$LREC^CIMSNCI1(CIMSLAB,"NCI RECORD C")
..S CIMSC=CIMSC+1
..S ^TMP("CIMSNCI",$J,"C",CIMSC)=X
.;go through meds and generate D
.S CIMSMED=0 F S CIMSMED=$O(^AUPNVMED("AD",CIMVSIT,CIMSMED)) Q:CIMSMED'=+CIMSMED D
..S X=$$MREC^CIMSNCI1(CIMSMED,"NCI RECORD D")
..S CIMSD=CIMSD+1
..S ^TMP("CIMSNCI",$J,"D",CIMSD)=X
..Q
.Q
Q
GENE ;
S CIMSPRB=0 F S CIMSPRB=$O(^AUPNPROB("AC",DFN,CIMSPRB)) Q:CIMSPRB'=+CIMSPRB D
.S X=$$PREC^CIMSNCI1(CIMSPRB,"NCI RECORD E")
.S CIMSE=CIMSE+1
.S ^TMP("CIMSNCI",$J,"E",CIMSE)=X
.Q
Q
NPR(V) ;
NEW C,X
S (X,C)=0
F S X=$O(^AUPNVPRC("AD",V,X)) Q:X'=+X S C=C+1
Q C
HF(V,N) ;return N health factor on this visit
NEW X,C,%
S %="",(X,C)=0 F S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X S C=C+1 I C=N S %=$P(^AUTTHF($P(^AUPNVHF(X,0),U),0),U)
Q %
DATE(D) ;EP convert internal fileman format to mmddyyyy
I $G(D)="" Q ""
Q $E(D,4,7)_($E(D,1,3)+1700)
VPR(P,D) ;
I '$G(P) Q 0
I $G(D)="" Q 0
NEW X,C,B
S (X,C)=0
S B=$$FMADD^XLFDT(D,-365)
F S X=$O(^AUPNVSIT("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNVSIT(X,0),U,11) ;deleted
.Q:'$P(^AUPNVSIT(X,0),U,9) ;no dep
.Q:"AH"'[$P(^AUPNVSIT(X,0),U,7)
.Q:$P(^AUPNVSIT(X,0),U,6)'=DUZ(2)
.Q:'$D(^AUPNVPOV("AD",X))
.Q:'$D(^AUPNVPRV("AD",X))
.Q:$P($P(^AUPNVSIT(X,0),U),".")>D
.Q:$P($P(^AUPNVSIT(X,0),U),".")<B
.S C=C+1
Q C
LASTHT(P,F,CIMSTYPE,CIMSDATE) ;PEP - return last ht before dx date
I 'P Q ""
I $G(CIMSDATE)="" Q ""
I $G(CIMSTYPE)="" S CIMSTYPE="V"
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW %,APCLARRY,H,E,G,A,B,D
S A=$$FMTE^XLFDT(CIMSDATE),B="JAN 01, 1900"
S %=P_"^LAST MEAS HT;DURING "_B_"-"_A NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2),D=$P($G(APCLARRY(1)),U,1)
I H]"",CIMSTYPE="V" S H=$J(H,2,0) Q $S(F="I":H,1:(H\12)_" "_(H#12))
I H]"",CIMSTYPE="D" Q D
S A=$$FMTE^XLFDT(DT),B=$$FMTE^XLFDT(CIMSDATE)
S %=P_"^LAST MEAS HT;DURING "_B_"-"_A NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2),D=$P($G(APCLARRY(1)),U,1)
I H="" Q H
I H]"",CIMSTYPE="V" S H=$J(H,2,0) Q $S(F="I":H,1:(H\12)_" "_(H#12))
I H]"",CIMSTYPE="D" Q D
;F="I" - in inches, F="E" - feet and inches 5 5
LASTWT(P,CIMSTYPE,CIMSDATE) ;PEP - return last wt
I 'P Q ""
I $G(CIMSDATE)="" Q ""
I $G(CIMSTYPE)="" S CIMSTYPE="V"
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW %,APCLARRY,H,E,G,A,B,D
S A=$$FMTE^XLFDT(CIMSDATE),B="JAN 01, 1900"
S %=P_"^LAST MEAS WT;DURING "_B_"-"_A NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2),D=$P($G(APCLARRY(1)),U,1)
I H]"",CIMSTYPE="V" S H=$J(H,3,1) Q H
I H]"",CIMSTYPE="D" Q D
S A=$$FMTE^XLFDT(DT),B=$$FMTE^XLFDT(CIMSDATE)
S %=P_"^LAST MEAS WT;DURING "_B_"-"_A NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2),D=$P($G(APCLARRY(1)),U,1)
I H="" Q H
I H]"",CIMSTYPE="V" S H=$J(H,3,1) Q H
I H]"",CIMSTYPE="D" Q D
BMI(P) ;PEP - return BMI with last weight,last height
I 'P Q -1
NEW %,W,H,B
S %=""
S W=$$LASTWT(P,"V",$P(^CIMSCPAT(P,0),U,4)) I W="" Q %
S H=$$LASTHT(P,"I","V",$P(^CIMSCPAT(P,0),U,4)) I H="" Q %
S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
Q %
ERR W $C(7),$C(7),!,"Must be a valid Year. Enter a year only!!" Q
RZERO(V,L) ;ep right zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
Q V
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
RBLK(V,L) ;EP right blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
Q V
EOJ ;
D ^XBFMK
K X,X1,X2,IO("Q"),%,Y,%DT,%Y,%W,%T,%H,DUOUT,DTOUT,POP,ZTSK,ZTQUEUED,H,S,TS,M,DFN
D KILL^AUPNPAT
D EN^XBVK("CIM"),EN^XBVK("APCL"),EN^XBVK("AUPN")
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
;
W:$D(IOF) @IOF
W !,$$CTR("NATIONAL CANCER INSTITUTE",80)
W !,$$CTR("Patterns of Care Among Native American Cancer Patients",80)
W !,$$CTR("Main Study Menu"),!
W !,$$CTR($$LOC(),80)
W !,$$CTR("Version 1.0 April 1998",80)
W !,$$CTR("Cimarron Medical Informatics, LLC",80)
Q
INTRO ;
;;This program will download data from the RPMS system to support the study
;;identified above. Data will be downloaded for each patient who is entered
;;into the NCI CANCER STUDY PATIENT REGISTER file.
;;
;;Five files of data will be created. They will be named:
;; - ncifilea.nnn
;; - ncifileb.nnn
;; - ncifilec.nnn
;; - ncifiled.nnn
;; - ncifilee.nnn (nnn is the julian date when the file was created)
;;The files will be placed in the export directory. (/usr/spool/uucppublic
;;if you are on a unix machine, C:\EXPORT on DOS)
;;
;;Please jot down these file names for future reference.
;;
;;END
;
;
CIMSNCID ; CMI/TUCSON/LAB -NCI STUDY ; [ 06/09/98 6:56 AM ]
+1 ;;1.0;NCI STUDY EXTRACT 1.0;;MAY 14, 1998
+2 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC(),80),!
+3 SET X="***** NCI CANCER STUDY *****"
WRITE !,$$CTR(X,80)
+4 SET X="Patterns of Care Among Native American Cancer Patients"
WRITE !,$$CTR(X,80),!
+5 SET T="INTRO"
FOR J=1:1
SET X=$TEXT(@T+J)
SET X=$PIECE(X,";;",2)
IF X="END"
QUIT
WRITE !,X
+6 KILL J,X,T
+7 WRITE !,"There are "
SET X=0
SET C=0
FOR
SET X=$ORDER(^CIMSCPAT(X))
IF X'=+X
QUIT
SET C=C+1
+8 WRITE C," patients in the NCI Cancer Study Register.",!
+9 ;
YEARS ;
+1 SET CIMSYRS=0
+2 SET DIR(0)="N^1:99:0"
SET DIR("A")="How many years of data should be downloaded"
SET DIR("B")="1"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO EOJ
+4 SET CIMSYRS=Y
CONT ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+2 IF Y'=1
DO EOJ
QUIT
+3 IF $DATA(DIRUT)
DO EOJ
QUIT
QUEUE ;EP
+1 KILL ZTSK
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to QUEUE this to run at a later time"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF Y=1
DO EOJ
DO QUEUE1
QUIT
+4 IF $DATA(DIRUT)
DO EOJ
QUIT
+5 DO PROC
+6 QUIT
QUEUE1 ;
+1 SET ZTRTN="PROC^CIMSNCID"
+2 SET ZTIO=""
SET ZTDTH=""
SET ZTDESC="NCI STUDY EXPORT SYSTEM"
SET ZTSAVE("CIM*")=""
+3 DO ^%ZTLOAD
+4 WRITE !!,$SELECT($DATA(ZTSK):"Request Queued.",1:"Request cancelled.")
+5 IF '$DATA(ZTSK)
SET Q=99
QUIT
+6 KILL ZTSK
+7 QUIT
PROC ;EP - called from xbdbque to process patients
+1 IF '$DATA(ZTQUEUED)
WRITE !,"Processing patients"
+2 SET CIMSH=$HOROLOG
SET CIMSJ=$JOB
SET (CIMSA,CIMSB,CIMSC,CIMSD,CIMSE)=0
+3 KILL ^TMP("CIMSNCI",$JOB,CIMSJ,CIMSH)
+4 SET DFN=0
FOR
SET DFN=$ORDER(^CIMSCPAT(DFN))
IF DFN'=+DFN
QUIT
SET CIMSDDX=$PIECE(^CIMSCPAT(DFN,0),U,4)
Begin DoDot:1
+5 IF '$DATA(ZTQUEUED)
WRITE "."
DO GENA
+6 DO GENB
+7 DO GENE
+8 QUIT
End DoDot:1
WRITEF ;write out flat file
A ;
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Writing out file A"
+2 SET X2=$EXTRACT(DT,1,3)_"0101"
SET X1=DT
DO ^%DTC
SET CIMSJD=X+1
+3 KILL ^TMP($JOB)
SET X=0
FOR
SET X=$ORDER(^TMP("CIMSNCI",$JOB,"A",X))
IF X'=+X
QUIT
SET ^TMP($JOB,X)=^TMP("CIMSNCI",$JOB,"A",X)
+4 SET XBGL="TMP("_$JOB_","
+5 SET F="ncifilea."_CIMSJD
+6 SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+7 DO ^XBGSAVE
B ;
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Writing out file B"
+2 KILL ^TMP($JOB)
SET X=0
FOR
SET X=$ORDER(^TMP("CIMSNCI",$JOB,"B",X))
IF X'=+X
QUIT
SET ^TMP($JOB,X)=^TMP("CIMSNCI",$JOB,"B",X)
+3 SET XBGL="TMP("_$JOB_","
SET F="ncifileb."_CIMSJD
SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+4 DO ^XBGSAVE
C ;
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Writing out file C"
+2 KILL ^TMP($JOB)
SET X=0
FOR
SET X=$ORDER(^TMP("CIMSNCI",$JOB,"C",X))
IF X'=+X
QUIT
SET ^TMP($JOB,X)=^TMP("CIMSNCI",$JOB,"C",X)
+3 SET XBGL="TMP("_$JOB_","
SET F="ncifilec."_CIMSJD
SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+4 DO ^XBGSAVE
D ;
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Writing out file D"
+2 KILL ^TMP($JOB)
SET X=0
FOR
SET X=$ORDER(^TMP("CIMSNCI",$JOB,"D",X))
IF X'=+X
QUIT
SET ^TMP($JOB,X)=^TMP("CIMSNCI",$JOB,"D",X)
+3 SET XBGL="TMP("_$JOB_","
SET F="ncifiled."_CIMSJD
SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+4 DO ^XBGSAVE
E ;
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Writing out file E"
+2 KILL ^TMP($JOB)
SET X=0
FOR
SET X=$ORDER(^TMP("CIMSNCI",$JOB,"E",X))
IF X'=+X
QUIT
SET ^TMP($JOB,X)=^TMP("CIMSNCI",$JOB,"E",X)
+3 SET XBGL="TMP("_$JOB_","
SET F="ncifilee."_CIMSJD
SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF NCI EXTRACT STUDY RECORDS BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+4 DO ^XBGSAVE
+5 KILL ^TMP("CIMSNCI",$JOB)
+6 KILL ^TMP($JOB)
+7 KILL XBGL,XBMED,XBTLE,XBFN,XBF,XBQ,XBFLT
+8 DO EOJ
+9 QUIT
GENA ;generate file a record
+1 SET X=$$AREC^CIMSNCI1(DFN,CIMSDDX,"NCI RECORD A")
+2 SET CIMSA=CIMSA+1
+3 SET ^TMP("CIMSNCI",$JOB,"A",CIMSA)=X
+4 QUIT
GENB ;
+1 ;go through all visits 1 year prior to 1 year after cimsddx
+2 IF CIMSDDX=""
QUIT
+3 SET CIMSBG=$$FMADD^XLFDT(CIMSDDX,(-365.25*CIMSYRS))
SET CIMSED=$$FMADD^XLFDT(CIMSDDX,(365.25*CIMSYRS))
+4 SET CIMVSIT=0
FOR
SET CIMVSIT=$ORDER(^AUPNVSIT("AC",DFN,CIMVSIT))
IF CIMVSIT'=+CIMVSIT
QUIT
Begin DoDot:1
+5 SET D=$PIECE($PIECE(^AUPNVSIT(CIMVSIT,0),U),".")
+6 IF D<CIMSBG
QUIT
+7 IF D>CIMSED
QUIT
+8 IF $PIECE(^AUPNVSIT(CIMVSIT,0),U,11)
QUIT
+9 IF '$PIECE(^AUPNVSIT(CIMVSIT,0),U,9)
QUIT
+10 IF "AH"'[$PIECE(^AUPNVSIT(CIMVSIT,0),U,7)
QUIT
+11 ;Q:'$D(^AUPNVPOV("AD",CIMVSIT))
+12 ;Q:'$D(^AUPNVPRV("AD",CIMVSIT))
+13 IF $PIECE(^AUPNVSIT(CIMVSIT,0),U,6)'=DUZ(2)
QUIT
+14 IF $DATA(^AUPNVPOV("AD",CIMVSIT))
IF $DATA(^AUPNVPRV("AD",CIMVSIT))
Begin DoDot:2
+15 SET X=$$BREC^CIMSNCI1(CIMVSIT,"NCI RECORD B")
+16 SET CIMSB=CIMSB+1
+17 SET ^TMP("CIMSNCI",$JOB,"B",CIMSB)=X
End DoDot:2
+18 ;DO GENERATE C RECORDS
+19 SET CIMSLAB=0
FOR
SET CIMSLAB=$ORDER(^AUPNVLAB("AD",CIMVSIT,CIMSLAB))
IF CIMSLAB'=+CIMSLAB
QUIT
Begin DoDot:2
+20 SET X=$$LREC^CIMSNCI1(CIMSLAB,"NCI RECORD C")
+21 SET CIMSC=CIMSC+1
+22 SET ^TMP("CIMSNCI",$JOB,"C",CIMSC)=X
End DoDot:2
+23 ;go through meds and generate D
+24 SET CIMSMED=0
FOR
SET CIMSMED=$ORDER(^AUPNVMED("AD",CIMVSIT,CIMSMED))
IF CIMSMED'=+CIMSMED
QUIT
Begin DoDot:2
+25 SET X=$$MREC^CIMSNCI1(CIMSMED,"NCI RECORD D")
+26 SET CIMSD=CIMSD+1
+27 SET ^TMP("CIMSNCI",$JOB,"D",CIMSD)=X
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 QUIT
GENE ;
+1 SET CIMSPRB=0
FOR
SET CIMSPRB=$ORDER(^AUPNPROB("AC",DFN,CIMSPRB))
IF CIMSPRB'=+CIMSPRB
QUIT
Begin DoDot:1
+2 SET X=$$PREC^CIMSNCI1(CIMSPRB,"NCI RECORD E")
+3 SET CIMSE=CIMSE+1
+4 SET ^TMP("CIMSNCI",$JOB,"E",CIMSE)=X
+5 QUIT
End DoDot:1
+6 QUIT
NPR(V) ;
+1 NEW C,X
+2 SET (X,C)=0
+3 FOR
SET X=$ORDER(^AUPNVPRC("AD",V,X))
IF X'=+X
QUIT
SET C=C+1
+4 QUIT C
HF(V,N) ;return N health factor on this visit
+1 NEW X,C,%
+2 SET %=""
SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVHF("AD",V,X))
IF X'=+X
QUIT
SET C=C+1
IF C=N
SET %=$PIECE(^AUTTHF($PIECE(^AUPNVHF(X,0),U),0),U)
+3 QUIT %
DATE(D) ;EP convert internal fileman format to mmddyyyy
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,7)_($EXTRACT(D,1,3)+1700)
VPR(P,D) ;
+1 IF '$GET(P)
QUIT 0
+2 IF $GET(D)=""
QUIT 0
+3 NEW X,C,B
+4 SET (X,C)=0
+5 SET B=$$FMADD^XLFDT(D,-365)
+6 FOR
SET X=$ORDER(^AUPNVSIT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;deleted
IF $PIECE(^AUPNVSIT(X,0),U,11)
QUIT
+8 ;no dep
IF '$PIECE(^AUPNVSIT(X,0),U,9)
QUIT
+9 IF "AH"'[$PIECE(^AUPNVSIT(X,0),U,7)
QUIT
+10 IF $PIECE(^AUPNVSIT(X,0),U,6)'=DUZ(2)
QUIT
+11 IF '$DATA(^AUPNVPOV("AD",X))
QUIT
+12 IF '$DATA(^AUPNVPRV("AD",X))
QUIT
+13 IF $PIECE($PIECE(^AUPNVSIT(X,0),U),".")>D
QUIT
+14 IF $PIECE($PIECE(^AUPNVSIT(X,0),U),".")<B
QUIT
+15 SET C=C+1
End DoDot:1
+16 QUIT C
LASTHT(P,F,CIMSTYPE,CIMSDATE) ;PEP - return last ht before dx date
+1 IF 'P
QUIT ""
+2 IF $GET(CIMSDATE)=""
QUIT ""
+3 IF $GET(CIMSTYPE)=""
SET CIMSTYPE="V"
+4 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+5 NEW %,APCLARRY,H,E,G,A,B,D
+6 SET A=$$FMTE^XLFDT(CIMSDATE)
SET B="JAN 01, 1900"
+7 SET %=P_"^LAST MEAS HT;DURING "_B_"-"_A
NEW X
SET E=$$START1^APCLDF(%,"APCLARRY(")
SET H=$PIECE($GET(APCLARRY(1)),U,2)
SET D=$PIECE($GET(APCLARRY(1)),U,1)
+8 IF H]""
IF CIMSTYPE="V"
SET H=$JUSTIFY(H,2,0)
QUIT $SELECT(F="I":H,1:(H\12)_" "_(H#12))
+9 IF H]""
IF CIMSTYPE="D"
QUIT D
+10 SET A=$$FMTE^XLFDT(DT)
SET B=$$FMTE^XLFDT(CIMSDATE)
+11 SET %=P_"^LAST MEAS HT;DURING "_B_"-"_A
NEW X
SET E=$$START1^APCLDF(%,"APCLARRY(")
SET H=$PIECE($GET(APCLARRY(1)),U,2)
SET D=$PIECE($GET(APCLARRY(1)),U,1)
+12 IF H=""
QUIT H
+13 IF H]""
IF CIMSTYPE="V"
SET H=$JUSTIFY(H,2,0)
QUIT $SELECT(F="I":H,1:(H\12)_" "_(H#12))
+14 IF H]""
IF CIMSTYPE="D"
QUIT D
+15 ;F="I" - in inches, F="E" - feet and inches 5 5
LASTWT(P,CIMSTYPE,CIMSDATE) ;PEP - return last wt
+1 IF 'P
QUIT ""
+2 IF $GET(CIMSDATE)=""
QUIT ""
+3 IF $GET(CIMSTYPE)=""
SET CIMSTYPE="V"
+4 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+5 NEW %,APCLARRY,H,E,G,A,B,D
+6 SET A=$$FMTE^XLFDT(CIMSDATE)
SET B="JAN 01, 1900"
+7 SET %=P_"^LAST MEAS WT;DURING "_B_"-"_A
NEW X
SET E=$$START1^APCLDF(%,"APCLARRY(")
SET H=$PIECE($GET(APCLARRY(1)),U,2)
SET D=$PIECE($GET(APCLARRY(1)),U,1)
+8 IF H]""
IF CIMSTYPE="V"
SET H=$JUSTIFY(H,3,1)
QUIT H
+9 IF H]""
IF CIMSTYPE="D"
QUIT D
+10 SET A=$$FMTE^XLFDT(DT)
SET B=$$FMTE^XLFDT(CIMSDATE)
+11 SET %=P_"^LAST MEAS WT;DURING "_B_"-"_A
NEW X
SET E=$$START1^APCLDF(%,"APCLARRY(")
SET H=$PIECE($GET(APCLARRY(1)),U,2)
SET D=$PIECE($GET(APCLARRY(1)),U,1)
+12 IF H=""
QUIT H
+13 IF H]""
IF CIMSTYPE="V"
SET H=$JUSTIFY(H,3,1)
QUIT H
+14 IF H]""
IF CIMSTYPE="D"
QUIT D
BMI(P) ;PEP - return BMI with last weight,last height
+1 IF 'P
QUIT -1
+2 NEW %,W,H,B
+3 SET %=""
+4 SET W=$$LASTWT(P,"V",$PIECE(^CIMSCPAT(P,0),U,4))
IF W=""
QUIT %
+5 SET H=$$LASTHT(P,"I","V",$PIECE(^CIMSCPAT(P,0),U,4))
IF H=""
QUIT %
+6 SET W=(W/5)*2.3
SET H=(H*2.5)
SET H=(H*H)/10000
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+7 QUIT %
ERR WRITE $CHAR(7),$CHAR(7),!,"Must be a valid Year. Enter a year only!!"
QUIT
RZERO(V,L) ;ep right zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_"0"
+3 QUIT V
LZERO(V,L) ;EP - left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
RBLK(V,L) ;EP right blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_" "
+3 QUIT V
EOJ ;
+1 DO ^XBFMK
+2 KILL X,X1,X2,IO("Q"),%,Y,%DT,%Y,%W,%T,%H,DUOUT,DTOUT,POP,ZTSK,ZTQUEUED,H,S,TS,M,DFN
+3 DO KILL^AUPNPAT
+4 DO EN^XBVK("CIM")
DO EN^XBVK("APCL")
DO EN^XBVK("AUPN")
+5 QUIT
+6 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
+3 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR("NATIONAL CANCER INSTITUTE",80)
+3 WRITE !,$$CTR("Patterns of Care Among Native American Cancer Patients",80)
+4 WRITE !,$$CTR("Main Study Menu"),!
+5 WRITE !,$$CTR($$LOC(),80)
+6 WRITE !,$$CTR("Version 1.0 April 1998",80)
+7 WRITE !,$$CTR("Cimarron Medical Informatics, LLC",80)
+8 QUIT
INTRO ;
+1 ;;This program will download data from the RPMS system to support the study
+2 ;;identified above. Data will be downloaded for each patient who is entered
+3 ;;into the NCI CANCER STUDY PATIENT REGISTER file.
+4 ;;
+5 ;;Five files of data will be created. They will be named:
+6 ;; - ncifilea.nnn
+7 ;; - ncifileb.nnn
+8 ;; - ncifilec.nnn
+9 ;; - ncifiled.nnn
+10 ;; - ncifilee.nnn (nnn is the julian date when the file was created)
+11 ;;The files will be placed in the export directory. (/usr/spool/uucppublic
+12 ;;if you are on a unix machine, C:\EXPORT on DOS)
+13 ;;
+14 ;;Please jot down these file names for future reference.
+15 ;;
+16 ;;END
+17 ;
+18 ;
