BMXADOV1.m

BMXADOV1 ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ;

 ;;4.0;BMX;;JUN 28, 2010

 ; CONTINUATION FILE FOR BMXADOV

 ; MANAGES ITERATION FOR INDIVIDUAL INDEX TYPES

 ; ASSUMES CERTAIN LOCAL VARS: CREF,FIEN,IENS,DAS (<-THESE CAN'T BE NULL),START,STOP,MAX,TOT,NUM,IX

 ; 

 ; 

 ;

DATA(IENS,DA,XCNT) ;EP - ADD DATA NODES TO ARRAY

 ; ASSUMES THAT VSTG VARIABLES AND THE OUT ARRAY ARE PRESENT

 I '$G(DA) Q

 I '$L(IENS) Q

 S $P(IENS,C)=DA

 N STG,X,Y,%,FLD,STOP,VAL,CNT,FIEN,LINE,IFLAG,IDEP,TFLD,TNO,TEF

 S STG=DA

 I $G(DAS),$E(DAS,$L(DAS))="," S STG=$TR(DAS,",",U)_STG ; FIX FOR SUBFILE

 S CNT=$L(IENS,",") ; START AFTER THE .001 FIELD

 I $G(SUB) S STG=$P(IENS,C,2)_U_DA ; MAKE DAS FOR A SUBFILE.  THIS WILL BE THE IST PIECE OF THE DATA STRING

 I $G(XCNT) S CNT=XCNT ; USED WITH JOINS

 F  S CNT=$O(@OUT@(CNT)) Q:'CNT  Q:$G(STOP)  D  I @OUT@(CNT)[$C(30) Q  ; LOOP TO CREATE THE DATA STRING

 . K IFLAG,IDEP

 . S FIEN=+@OUT@(CNT) I '$D(^DD(FIEN,0)) S STOP=1 Q

 . S FLD=$P(@OUT@(CNT),B,2)

 . I FLD=".01ID" D  Q  ; PROCESS THE IDENTIFIER FIELD

 .. I '$G(SIEN) Q

 .. S %=$O(^BMXADO(SIEN,1,"B",".01ID",0)) I '% Q

 .. S IDEP=$G(^BMXADO(SIEN,1,%,1)) I '$L(IDEP) Q

 .. X ("S VAL=$$"_IDEP_"("_+STG_")") ; PASS THE DA TO THE IDENTIFIER EXTRINSIC FUNCTION, RETURN IDENTIFIERS

 .. S VAL=$TR(VAL,"^",""),VAL=$TR(VAL,B,"")

 .. S STG=STG_U_VAL

 .. Q

 . I $G(SIEN),FLD S %=$O(^BMXADO(SIEN,1,"B",FLD,0)) I %,$P($G(^BMXADO(SIEN,1,%,0)),U,9) S IFLAG=1 ; SCHEMA FILE SAYS FORCE INTERNAL VALUE FOR THIS FIELD

 . K TFLD

 . I FLD["TRIGGER" S TFLD=FLD,FLD=+FLD,IFLAG=1

 . I FLD["IEN" S FLD=+FLD,IFLAG=1 ; LOOKUP VALUE FIELD (IEN)

 . I '$D(^DD(FIEN,FLD,0)),FLD'=.001 S STOP=1 Q

 . I $D(TFLD),FLD=.001 S VAL=+IENS

 . E  S VAL=$$GET1^DIQ(FIEN,IENS,FLD,$S($G(IFLAG):"I",$G(TFLAG):"I",1:$G(FMT)))

 . I $G(TFLD) D  S STG=STG_U_VAL Q  ; GENERATE A TRIGGERED VALUE FOR THIS FIELD

 .. S TNO=$O(^BMXADO(SIEN,1,"B",TFLD,0)) I 'TNO S VAL="" Q

 .. S TEF=$G(^BMXADO(SIEN,1,TNO,3)) I '$L(TEF) S VAL="" Q  ; GET EXTR FUNCT THAT GENERATES A SECONDARY VALUE

 .. X ("S VAL=$$"_TEF_"(VAL)")

 .. Q

 . I FLD=.01,VAL="" S STOP=1 Q  ; INVALID FILEMAN ENTRY!  SKIP IT

 . S VAL=$TR(VAL,"^",""),VAL=$TR(VAL,B,"")

 . S STG=STG_U_VAL

 . Q

 I $G(STOP) Q  ; DON'T ADD NODE IF DD INFO IS INVALID

 F  S LINE=$E(STG,1,250),STG=$E(STG,251,999999) D  I '$L(STG) Q  ; PREVENTS DATA LENGTH FROM EXCEEDING 250 BYTES

 . S TOT=TOT+1

 . I '$L(STG) S LINE=LINE_$C(30),NUM=NUM+1 ; END OF RECORD, RECORD TOTAL IS UPDATED

 . S @OUT@(TOT)=LINE ; NODE IS ADDED

 . Q

 Q

 ; 

NUMIT(DA) ; EP-ITERATE BY NUMBER

 N XIT,LDA

 I IENS S DA=+IENS ; RE-ENTRY FROM SEED

 I '$G(DA),$G(START) S DA=START-1

 I '$G(DA) S DA=0

 S LDA=""

 F  S DA=$O(@CREF@(DA)) D  I $G(XIT) Q

 . I 'DA S XIT=1,LDA="" Q  ; NO MORE IENS - THE END OF THE LINE

 . D DATA(IENS,DA,+$G(XCNT))

 . I $G(STOP),$O(@CREF@(DA))>STOP S LDA="",XIT=1 Q  ; AS FAR AS YOU ARE ALLOWED TO GO FOR NUMBER ITERATION

 . I NUM=MAX S LDA=DA,XIT=1 Q  ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME

 . Q

 I LDA,'$O(@CREF@(LDA)) S LDA="" ; END OF THE LINE SO SET LDA TO NULL

 Q LDA

 ; 

LOOK(LIEN) ; EP-ITERATE BY A SINGLE STANDARD INDEX THAT IS A POINTER VALUE

 N XIT,LDA

 S DA=+IENS

 F  S DA=$O(@CREF@(IX,LIEN,DA)) D  I $G(XIT) Q

 . I 'DA S XIT=1,LDA="" Q  ; NO MORE IENS - THE END OF THE LINE

 . D DATA(IENS,DA,$G(XCNT))

 . I NUM=MAX S LDA=DA,XIT=1 Q  ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME

 . Q

 I '$O(@CREF@(IX,LIEN,DA)) Q ""

 Q LDA

 ;

LOOK1() ; EP-ITERATE USING A STANDARD INDEX

 N XIT,LDA,VAL,DA,%

 S DA=+IENS I 'DA G SCRATCH ; CHECK FOR RE-RENTRY

REENTER ; RE-ENTER STD ITERATION USING DA AS THE SEED

 S %=$$IXVAL(FIEN,IX,DAS) I '$L(%) Q "" ; GET STARTUP INFO

LR S VAL=$P(%,B,3)

 I VAL="" Q "" ; NO VAL FOUND FOR INITIAL ITERATION, SO QUIT

 F  S DA=$O(@CREF@(IX,VAL,DA)) Q:'DA  D DATA(IENS,DA,+$G(XCNT)) I NUM=MAX S LDA=DA,XIT=1 Q  ; SWEEP UP ALL THE REMAINING DAS UNDER THE CURRENT VALUE

 I $G(XIT) Q:'$O(@CREF@(IX,VAL,LDA)) "" Q LDA ; IF NO MORE AFTER MAX, SET LDA = NULL

 G LOOK1R ; SEED IS DEFINED

SCRATCH S VAL="" ; STD LOOKUP STARTING FROM SCRATCH

 I $L(START) S VAL=$O(@CREF@(IX,START),-1) ; GET SEED FOR ITERATION

LOOK1R F  S VAL=$O(@CREF@(IX,VAL)) D  I $G(XIT) Q  ; EP - RE-ENTRY POINT IF SEED IS DEFINED

 . I VAL="" S LDA="",XIT=1 Q  ; END OF THE LINE

 . I STOP=+STOP,VAL=+VAL,VAL>STOP S LDA="",XIT=1 Q

 . I $L(STOP),VAL]STOP S LDA="",XIT=1 Q  ; LOOKUP LIMITS

 . S DA=0

 . F  S DA=$O(@CREF@(IX,VAL,DA)) Q:'DA  D  I $G(XIT) Q

 .. D DATA(IENS,DA,+$G(XCNT))

 .. I NUM=MAX S LDA=DA,XIT=1 D  ; TRANSACTION LIMIT ; CHECK FOR MORE

 ... I $O(@CREF@(IX,VAL,DA)) Q

 ... S %=$O(@CREF@(IX,VAL)) I %="" S LDA="" Q

 ... I $L(STOP),%]STOP S LDA="" Q

 ... I '$O(@CREF@(IX,%,0)) S LDA="" Q

 ... Q

 .. Q

 . Q

 Q LDA

 ;

LOOK2(LFILE) ; EP-TEXT POINTER LOOKUP

 ; CHANGE THE GLOBAL REFERENCE FOR THE LOOKUP TO THE POINTED-TO FILE BEFORE PROCEEDING

 N XIT,LDA,OREF,CREF,VAL,DA

 S OREF=$$ROOT^DILFD(LFILE,IENS) I '$L(OREF) Q ""

 S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""

 S DA=+IENS

 I '$G(DA) G SCRATCH ; START FROM SCRATCH

 S %=$$IXVAL(LFILE,IX,DAS) I '$L(%) Q ""

 G LR ; RE-ENTER

 ;

IXVAL(FIEN,IX,DAS) ; GIVEN A FILE IEN, INDEX NAME, AND DAS STRING, RETURN THE VALUE USED IN THE INDEX

 N DA,FLD,IENS,OREF,CREF,XREF,VAL,UP,LEV,L

 I '$D(^DD(+$G(FIEN),0)) Q "" ; MISSING OR INVALID FILE NUMBER

 I '$L($G(IX)) Q "" ; NO INDEX SPECIFIED

 S UP=FIEN F LEV=1:1 S UP=$G(^DD(UP,0,"UP")) Q:'UP

 I LEV'=$L(DAS,C) Q "" ; DAS LEVELS MUST MATCH FILE OR SUBFILE LEVEL

 S IENS=$$IENS^BMXADOV($G(DAS)) I IENS=U Q ""

 S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) Q ""

 S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""

 I '$D(@CREF@(IX)) Q CREF_"||" ; NO INDEX VALUES TO CHECK

 S XREF=OREF_IX_")"

 S DA=+IENS I 'DA Q CREF_"||"

 I '$D(@CREF@(DA)) Q CREF_"||" ; NO ENTRY EXISTS

 I IX="AA" G AA

 S FLD=+$$IXFLD^BMXADOV(FIEN,IX) I 'FLD Q "" ; INVALID DD

 S VAL=$$GET1^DIQ(FIEN,IENS,FLD,"I") I VAL="" Q "" ; VALUE IS NULL - NOTHING TO INDEX

 I '$D(@CREF@(IX,VAL,DA)) Q "" ; INVALID INDEX

 Q XREF_B_DA_B_VAL

 ;

AA() ;EP - VISIT/V-FILE ITERATION USING THE 'AA' INDEX

 N LDA,XIT,AAINFO,DA,%,X,Y,DFN,TYPE,ORD,ISTART,ISTOP,IDT,AAREF,%DT,DIC

 S X=OREF_"""AA"")",%=$Q(@X) I %="" Q ""

 S TYPE="" I $L(%,C)=5 S TYPE=$P(PARAM,B,2) I TYPE="" Q "" ; FOR CERTAIN V FILES, TYPE MUST BE DEFINED

 I $E(TYPE)="`" S TYPE=$E(TYPE,2,99) I 'TYPE Q "" ; REMOVE ` FROM TYPE IEN

 I $L(TYPE),'TYPE D  I TYPE'>0 Q "" ; QUIT IF INVALID TYPE

 . S %=$P($G(^DD(FIEN,.01,0)),U,2)

 . S DIC=+$P(%,"P",2) I '$D(^DD(DIC,.01,0)) Q

 . S X=TYPE,DIC(0)="M" D ^DIC I Y=-1 Q

 . S TYPE=+Y

 . Q

 S DFN=+PARAM

 I '$D(^DPT(DFN,0)) Q "" ; PATIENT DFN MUST BE DEFINED

 I 'TYPE S AAREF=OREF_"""AA"","_DFN_")"

 E  S AAREF=OREF_"""AA"","_DFN_","_TYPE_")"

 I '$D(@AAREF) Q "" ; IF NOTHING UNDER AA INDEX, DON'T BOTHER LOOKING

 S ISTART=9999999 I START S X=START,%DT="P" D ^%DT S ISTART=9999999-Y

 S ISTOP=0 I STOP S X=STOP,%DT="P" D ^%DT S ISTOP=9999999-Y

 S ORD=-1 I $P(PARAM,B,$L(PARAM,B))="R" S ORD=1 ; SORT IN CHRONOLOGICAL OR REVERSE CHRONOLOGICAL ORDER

 I ORD=-1 S X=$G(ISTART),Y=$G(ISTOP),ISTOP=X,ISTART=Y ; CHANGES REQUIRED TO PRESENT DATA IN CHRONOLIGICAL ORDER

 S IDT=0,LDA=""

 I ISTOP S IDT=ISTOP-.0000001

 S DA=+IENS

 I DA S IDT=$$AAR I 'IDT Q LDA ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY

 F  S IDT=$O(@AAREF@(IDT),ORD) Q:'IDT  D  I $G(XIT) Q

 . I ORD=1,IDT>ISTART S LDA="",XIT=1 Q

 . I ORD=-1,IDT<ISTART S LDA="",XIT=1 Q

 . S DA=0

 . F  S DA=$O(@AAREF@(IDT,DA)) Q:'DA  D  I $G(XIT) Q

 .. D DATA(IENS,DA,+$G(XCNT))

 .. I NUM=MAX S LDA=DA,XIT=1 I '$$AAMORE S LDA="" ; TRANSACTION LIMIT

 .. Q

 . Q

 Q LDA

 ; 

AAR() ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY

 N %,X,Y,XIT

 S %=$$AAVAL(FIEN,DAS) I '$L(%) Q ""

 S IDT=$P(%,B,5) I 'IDT Q ""

 F  S DA=$O(@AAREF@(IDT,DA)) Q:'DA  D  I $G(XIT) Q

 . D DATA(IENS,DA,+$G(XCNT))

 . I NUM=MAX S LDA=DA,IDT="",XIT="" I '$$AAMORE S LDA=""

 . Q

 Q IDT

 ; 

AAMORE() ; RETURN A '1' IF MORE ITERATION IS POSSIBLE

 N X

 I $O(@AAREF@(IDT,DA)) Q 1

 S X=$O(@AAREF@(IDT),ORD) I 'X Q 0

 I $O(@AAREF@(X,0)) Q 1

 Q 0

 ; 

AAVAL(FIEN,DAS) ; GIVEN A FILE AND DAS, RETURN INFO NECESSARY TO RE-CREATE THE 'AA' INDEX

 N DATE,IDT,DFN,TYPE,VIEN,%,OREF,CREF,DA,IENS

 I '$D(^DD(FIEN,.01,0)) Q ""

 S IENS=$$IENS^BMXADOV($G(DAS)) I IENS=U Q ""

 S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) Q ""

 S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""

 S DA=+IENS I '$D(@CREF@(DA)) Q ""

 I FIEN=9000010 S DFN=$P(@CREF@(DA,0),U,5),VIEN=DA

 E  S DFN=$P(@CREF@(DA,0),U,2),VIEN=$P(@CREF@(DA,0),U,3)

 I $D(^DPT(DFN,0)),$D(^AUPNVSIT(VIEN,0))

 E  Q ""

 S DATE=+$P($G(^AUPNVSIT(VIEN,0)),U) I 'DATE Q ""

 S IDT=(9999999-(DATE\1))

 S %=$P(DATE,".",2) I % S IDT=+(IDT_"."_%) I 'IDT Q ""

 S X=OREF_"""AA"")",%=$Q(@X) I %="" Q ""

 S TYPE="" I $L(%,C)=5 S TYPE=$P(@CREF@(DA,0),U)

 Q X_B_DA_B_DFN_B_TYPE_B_IDT

 ; 

AAP() ;EP - ITERATOR FOR PROBLEM FILE: AA INDEX

 I '$D(^AUPNPROB("AA",+$G(START))) Q ""

 N LOC,PNUM,DFN,IEN

 S LOC=0,DFN=START

 F  S LOC=$O(^AUPNPROB("AA",DFN,LOC)) Q:'LOC  D

 . S PNUM=""

 . F  S PNUM=$O(^AUPNPROB("AA",DFN,LOC,PNUM)) Q:PNUM=""  D

 .. S IEN=0

 .. F  S IEN=$O(^AUPNPROB("AA",DFN,LOC,PNUM,IEN)) Q:'IEN  D DATA(",",IEN,+$G(XCNT))

 .. Q

 .Q

 Q ""

 ; 

TESTID(DA) ; TEST IDENTIFIERS

 N %,Y,SEX

 S %=$G(^DIZ(2160010,+$G(DA),0)) I '$L(%) Q ""

 S SEX=$P(%,U,2) I '$L(SEX) S SEX="??"

 S Y=$P(%,U,3) X ^DD("DD")

 Q (SEX_"   "_Y)

 ; 

BMXADOV1  ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ;

 +1       ;;4.0;BMX;;JUN 28, 2010

 +2       ; CONTINUATION FILE FOR BMXADOV

 +3       ; MANAGES ITERATION FOR INDIVIDUAL INDEX TYPES

 +4       ; ASSUMES CERTAIN LOCAL VARS: CREF,FIEN,IENS,DAS (<-THESE CAN'T BE NULL),START,STOP,MAX,TOT,NUM,IX

 +5       ; 

 +6       ; 

 +7       ;

DATA(IENS,DA,XCNT) ;EP - ADD DATA NODES TO ARRAY

 +1       ; ASSUMES THAT VSTG VARIABLES AND THE OUT ARRAY ARE PRESENT

 +2        IF '$GET(DA)

               QUIT 

 +3        IF '$LENGTH(IENS)

               QUIT 

 +4        SET $PIECE(IENS,C)=DA

 +5        NEW STG,X,Y,%,FLD,STOP,VAL,CNT,FIEN,LINE,IFLAG,IDEP,TFLD,TNO,TEF

 +6        SET STG=DA

 +7       ; FIX FOR SUBFILE

           IF $GET(DAS)

               IF $EXTRACT(DAS,$LENGTH(DAS))=","

                   SET STG=$TRANSLATE(DAS,",",U)_STG

 +8       ; START AFTER THE .001 FIELD

           SET CNT=$LENGTH(IENS,",")

 +9       ; MAKE DAS FOR A SUBFILE.  THIS WILL BE THE IST PIECE OF THE DATA STRING

           IF $GET(SUB)

               SET STG=$PIECE(IENS,C,2)_U_DA

 +10      ; USED WITH JOINS

           IF $GET(XCNT)

               SET CNT=XCNT

 +11      ; LOOP TO CREATE THE DATA STRING

           FOR 

               SET CNT=$ORDER(@OUT@(CNT))

               IF 'CNT

                   QUIT 

               IF $GET(STOP)

                   QUIT 

               Begin DoDot:1

 +12               KILL IFLAG,IDEP

 +13               SET FIEN=+@OUT@(CNT)

                   IF '$DATA(^DD(FIEN,0))

                       SET STOP=1

                       QUIT 

 +14               SET FLD=$PIECE(@OUT@(CNT),B,2)

 +15      ; PROCESS THE IDENTIFIER FIELD

                   IF FLD=".01ID"

                       Begin DoDot:2

 +16                       IF '$GET(SIEN)

                               QUIT 

 +17                       SET %=$ORDER(^BMXADO(SIEN,1,"B",".01ID",0))

                           IF '%

                               QUIT 

 +18                       SET IDEP=$GET(^BMXADO(SIEN,1,%,1))

                           IF '$LENGTH(IDEP)

                               QUIT 

 +19      ; PASS THE DA TO THE IDENTIFIER EXTRINSIC FUNCTION, RETURN IDENTIFIERS

                           XECUTE ("S VAL=$$"_IDEP_"("_+STG_")")

 +20                       SET VAL=$TRANSLATE(VAL,"^","")

                           SET VAL=$TRANSLATE(VAL,B,"")

 +21                       SET STG=STG_U_VAL

 +22                       QUIT 

                       End DoDot:2

                       QUIT 

 +23      ; SCHEMA FILE SAYS FORCE INTERNAL VALUE FOR THIS FIELD

                   IF $GET(SIEN)

                       IF FLD

                           SET %=$ORDER(^BMXADO(SIEN,1,"B",FLD,0))

                           IF %

                               IF $PIECE($GET(^BMXADO(SIEN,1,%,0)),U,9)

                                   SET IFLAG=1

 +24               KILL TFLD

 +25               IF FLD["TRIGGER"

                       SET TFLD=FLD

                       SET FLD=+FLD

                       SET IFLAG=1

 +26      ; LOOKUP VALUE FIELD (IEN)

                   IF FLD["IEN"

                       SET FLD=+FLD

                       SET IFLAG=1

 +27               IF '$DATA(^DD(FIEN,FLD,0))

                       IF FLD'=.001

                           SET STOP=1

                           QUIT 

 +28               IF $DATA(TFLD)

                       IF FLD=.001

                           SET VAL=+IENS

 +29              IF '$TEST

                       SET VAL=$$GET1^DIQ(FIEN,IENS,FLD,$SELECT($GET(IFLAG):"I",$GET(TFLAG):"I",1:$GET(FMT)))

 +30      ; GENERATE A TRIGGERED VALUE FOR THIS FIELD

                   IF $GET(TFLD)

                       Begin DoDot:2

 +31                       SET TNO=$ORDER(^BMXADO(SIEN,1,"B",TFLD,0))

                           IF 'TNO

                               SET VAL=""

                               QUIT 

 +32      ; GET EXTR FUNCT THAT GENERATES A SECONDARY VALUE

                           SET TEF=$GET(^BMXADO(SIEN,1,TNO,3))

                           IF '$LENGTH(TEF)

                               SET VAL=""

                               QUIT 

 +33                       XECUTE ("S VAL=$$"_TEF_"(VAL)")

 +34                       QUIT 

                       End DoDot:2

                       SET STG=STG_U_VAL

                       QUIT 

 +35      ; INVALID FILEMAN ENTRY!  SKIP IT

                   IF FLD=.01

                       IF VAL=""

                           SET STOP=1

                           QUIT 

 +36               SET VAL=$TRANSLATE(VAL,"^","")

                   SET VAL=$TRANSLATE(VAL,B,"")

 +37               SET STG=STG_U_VAL

 +38               QUIT 

               End DoDot:1

               IF @OUT@(CNT)[$CHAR(30)

                   QUIT 

 +39      ; DON'T ADD NODE IF DD INFO IS INVALID

           IF $GET(STOP)

               QUIT 

 +40      ; PREVENTS DATA LENGTH FROM EXCEEDING 250 BYTES

           FOR 

               SET LINE=$EXTRACT(STG,1,250)

               SET STG=$EXTRACT(STG,251,999999)

               Begin DoDot:1

 +41               SET TOT=TOT+1

 +42      ; END OF RECORD, RECORD TOTAL IS UPDATED

                   IF '$LENGTH(STG)

                       SET LINE=LINE_$CHAR(30)

                       SET NUM=NUM+1

 +43      ; NODE IS ADDED

                   SET @OUT@(TOT)=LINE

 +44               QUIT 

               End DoDot:1

               IF '$LENGTH(STG)

                   QUIT 

 +45       QUIT 

 +46      ; 

NUMIT(DA) ; EP-ITERATE BY NUMBER

 +1        NEW XIT,LDA

 +2       ; RE-ENTRY FROM SEED

           IF IENS

               SET DA=+IENS

 +3        IF '$GET(DA)

               IF $GET(START)

                   SET DA=START-1

 +4        IF '$GET(DA)

               SET DA=0

 +5        SET LDA=""

 +6        FOR 

               SET DA=$ORDER(@CREF@(DA))

               Begin DoDot:1

 +7       ; NO MORE IENS - THE END OF THE LINE

                   IF 'DA

                       SET XIT=1

                       SET LDA=""

                       QUIT 

 +8                DO DATA(IENS,DA,+$GET(XCNT))

 +9       ; AS FAR AS YOU ARE ALLOWED TO GO FOR NUMBER ITERATION

                   IF $GET(STOP)

                       IF $ORDER(@CREF@(DA))>STOP

                           SET LDA=""

                           SET XIT=1

                           QUIT 

 +10      ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME

                   IF NUM=MAX

                       SET LDA=DA

                       SET XIT=1

                       QUIT 

 +11               QUIT 

               End DoDot:1

               IF $GET(XIT)

                   QUIT 

 +12      ; END OF THE LINE SO SET LDA TO NULL

           IF LDA

               IF '$ORDER(@CREF@(LDA))

                   SET LDA=""

 +13       QUIT LDA

 +14      ; 

LOOK(LIEN) ; EP-ITERATE BY A SINGLE STANDARD INDEX THAT IS A POINTER VALUE

 +1        NEW XIT,LDA

 +2        SET DA=+IENS

 +3        FOR 

               SET DA=$ORDER(@CREF@(IX,LIEN,DA))

               Begin DoDot:1

 +4       ; NO MORE IENS - THE END OF THE LINE

                   IF 'DA

                       SET XIT=1

                       SET LDA=""

                       QUIT 

 +5                DO DATA(IENS,DA,$GET(XCNT))

 +6       ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME

                   IF NUM=MAX

                       SET LDA=DA

                       SET XIT=1

                       QUIT 

 +7                QUIT 

               End DoDot:1

               IF $GET(XIT)

                   QUIT 

 +8        IF '$ORDER(@CREF@(IX,LIEN,DA))

               QUIT ""

 +9        QUIT LDA

 +10      ;

LOOK1()   ; EP-ITERATE USING A STANDARD INDEX

 +1        NEW XIT,LDA,VAL,DA,%

 +2       ; CHECK FOR RE-RENTRY

           SET DA=+IENS

           IF 'DA

               GOTO SCRATCH

REENTER   ; RE-ENTER STD ITERATION USING DA AS THE SEED

 +1       ; GET STARTUP INFO

           SET %=$$IXVAL(FIEN,IX,DAS)

           IF '$LENGTH(%)

               QUIT ""

LR         SET VAL=$PIECE(%,B,3)

 +1       ; NO VAL FOUND FOR INITIAL ITERATION, SO QUIT

           IF VAL=""

               QUIT ""

 +2       ; SWEEP UP ALL THE REMAINING DAS UNDER THE CURRENT VALUE

           FOR 

               SET DA=$ORDER(@CREF@(IX,VAL,DA))

               IF 'DA

                   QUIT 

               DO DATA(IENS,DA,+$GET(XCNT))

               IF NUM=MAX

                   SET LDA=DA

                   SET XIT=1

                   QUIT 

 +3       ; IF NO MORE AFTER MAX, SET LDA = NULL

           IF $GET(XIT)

               IF '$ORDER(@CREF@(IX,VAL,LDA))

                   QUIT ""

               QUIT LDA

 +4       ; SEED IS DEFINED

           GOTO LOOK1R

SCRATCH   ; STD LOOKUP STARTING FROM SCRATCH

           SET VAL=""

 +1       ; GET SEED FOR ITERATION

           IF $LENGTH(START)

               SET VAL=$ORDER(@CREF@(IX,START),-1)

LOOK1R    ; EP - RE-ENTRY POINT IF SEED IS DEFINED

           FOR 

               SET VAL=$ORDER(@CREF@(IX,VAL))

               Begin DoDot:1

 +1       ; END OF THE LINE

                   IF VAL=""

                       SET LDA=""

                       SET XIT=1

                       QUIT 

 +2                IF STOP=+STOP

                       IF VAL=+VAL

                           IF VAL>STOP

                               SET LDA=""

                               SET XIT=1

                               QUIT 

 +3       ; LOOKUP LIMITS

                   IF $LENGTH(STOP)

                       IF VAL]STOP

                           SET LDA=""

                           SET XIT=1

                           QUIT 

 +4                SET DA=0

 +5                FOR 

                       SET DA=$ORDER(@CREF@(IX,VAL,DA))

                       IF 'DA

                           QUIT 

                       Begin DoDot:2

 +6                        DO DATA(IENS,DA,+$GET(XCNT))

 +7       ; TRANSACTION LIMIT ; CHECK FOR MORE

                           IF NUM=MAX

                               SET LDA=DA

                               SET XIT=1

                               Begin DoDot:3

 +8                                IF $ORDER(@CREF@(IX,VAL,DA))

                                       QUIT 

 +9                                SET %=$ORDER(@CREF@(IX,VAL))

                                   IF %=""

                                       SET LDA=""

                                       QUIT 

 +10                               IF $LENGTH(STOP)

                                       IF %]STOP

                                           SET LDA=""

                                           QUIT 

 +11                               IF '$ORDER(@CREF@(IX,%,0))

                                       SET LDA=""

                                       QUIT 

 +12                               QUIT 

                               End DoDot:3

 +13                       QUIT 

                       End DoDot:2

                       IF $GET(XIT)

                           QUIT 

 +14               QUIT 

               End DoDot:1

               IF $GET(XIT)

                   QUIT 

 +15       QUIT LDA

 +16      ;

LOOK2(LFILE) ; EP-TEXT POINTER LOOKUP

 +1       ; CHANGE THE GLOBAL REFERENCE FOR THE LOOKUP TO THE POINTED-TO FILE BEFORE PROCEEDING

 +2        NEW XIT,LDA,OREF,CREF,VAL,DA

 +3        SET OREF=$$ROOT^DILFD(LFILE,IENS)

           IF '$LENGTH(OREF)

               QUIT ""

 +4        SET CREF=$$CREF^DILF(OREF)

           IF '$LENGTH(CREF)

               QUIT ""

 +5        SET DA=+IENS

 +6       ; START FROM SCRATCH

           IF '$GET(DA)

               GOTO SCRATCH

 +7        SET %=$$IXVAL(LFILE,IX,DAS)

           IF '$LENGTH(%)

               QUIT ""

 +8       ; RE-ENTER

           GOTO LR

 +9       ;

IXVAL(FIEN,IX,DAS) ; GIVEN A FILE IEN, INDEX NAME, AND DAS STRING, RETURN THE VALUE USED IN THE INDEX

 +1        NEW DA,FLD,IENS,OREF,CREF,XREF,VAL,UP,LEV,L

 +2       ; MISSING OR INVALID FILE NUMBER

           IF '$DATA(^DD(+$GET(FIEN),0))

               QUIT ""

 +3       ; NO INDEX SPECIFIED

           IF '$LENGTH($GET(IX))

               QUIT ""

 +4        SET UP=FIEN

           FOR LEV=1:1

               SET UP=$GET(^DD(UP,0,"UP"))

               IF 'UP

                   QUIT 

 +5       ; DAS LEVELS MUST MATCH FILE OR SUBFILE LEVEL

           IF LEV'=$LENGTH(DAS,C)

               QUIT ""

 +6        SET IENS=$$IENS^BMXADOV($GET(DAS))

           IF IENS=U

               QUIT ""

 +7        SET OREF=$$ROOT^DILFD(FIEN,IENS)

           IF '$LENGTH(OREF)

               QUIT ""

 +8        SET CREF=$$CREF^DILF(OREF)

           IF '$LENGTH(CREF)

               QUIT ""

 +9       ; NO INDEX VALUES TO CHECK

           IF '$DATA(@CREF@(IX))

               QUIT CREF_"||"

 +10       SET XREF=OREF_IX_")"

 +11       SET DA=+IENS

           IF 'DA

               QUIT CREF_"||"

 +12      ; NO ENTRY EXISTS

           IF '$DATA(@CREF@(DA))

               QUIT CREF_"||"

 +13       IF IX="AA"

               GOTO AA

 +14      ; INVALID DD

           SET FLD=+$$IXFLD^BMXADOV(FIEN,IX)

           IF 'FLD

               QUIT ""

 +15      ; VALUE IS NULL - NOTHING TO INDEX

           SET VAL=$$GET1^DIQ(FIEN,IENS,FLD,"I")

           IF VAL=""

               QUIT ""

 +16      ; INVALID INDEX

           IF '$DATA(@CREF@(IX,VAL,DA))

               QUIT ""

 +17       QUIT XREF_B_DA_B_VAL

 +18      ;

AA()      ;EP - VISIT/V-FILE ITERATION USING THE 'AA' INDEX

 +1        NEW LDA,XIT,AAINFO,DA,%,X,Y,DFN,TYPE,ORD,ISTART,ISTOP,IDT,AAREF,%DT,DIC

 +2        SET X=OREF_"""AA"")"

           SET %=$QUERY(@X)

           IF %=""

               QUIT ""

 +3       ; FOR CERTAIN V FILES, TYPE MUST BE DEFINED

           SET TYPE=""

           IF $LENGTH(%,C)=5

               SET TYPE=$PIECE(PARAM,B,2)

               IF TYPE=""

                   QUIT ""

 +4       ; REMOVE ` FROM TYPE IEN

           IF $EXTRACT(TYPE)="`"

               SET TYPE=$EXTRACT(TYPE,2,99)

               IF 'TYPE

                   QUIT ""

 +5       ; QUIT IF INVALID TYPE

           IF $LENGTH(TYPE)

               IF 'TYPE

                   Begin DoDot:1

 +6                    SET %=$PIECE($GET(^DD(FIEN,.01,0)),U,2)

 +7                    SET DIC=+$PIECE(%,"P",2)

                       IF '$DATA(^DD(DIC,.01,0))

                           QUIT