CIMSNCID.m

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")

 ;----------

 ;

HEADER ;EP called from menu header

 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