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
+8 SET X=TYPE
SET DIC(0)="M"
DO ^DIC
IF Y=-1
QUIT
+9 SET TYPE=+Y
+10 QUIT
End DoDot:1
IF TYPE'>0
QUIT ""
+11 SET DFN=+PARAM
+12 ; PATIENT DFN MUST BE DEFINED
IF '$DATA(^DPT(DFN,0))
QUIT ""
+13 IF 'TYPE
SET AAREF=OREF_"""AA"","_DFN_")"
+14 IF '$TEST
SET AAREF=OREF_"""AA"","_DFN_","_TYPE_")"
+15 ; IF NOTHING UNDER AA INDEX, DON'T BOTHER LOOKING
IF '$DATA(@AAREF)
QUIT ""
+16 SET ISTART=9999999
IF START
SET X=START
SET %DT="P"
DO ^%DT
SET ISTART=9999999-Y
+17 SET ISTOP=0
IF STOP
SET X=STOP
SET %DT="P"
DO ^%DT
SET ISTOP=9999999-Y
+18 ; SORT IN CHRONOLOGICAL OR REVERSE CHRONOLOGICAL ORDER
SET ORD=-1
IF $PIECE(PARAM,B,$LENGTH(PARAM,B))="R"
SET ORD=1
+19 ; CHANGES REQUIRED TO PRESENT DATA IN CHRONOLIGICAL ORDER
IF ORD=-1
SET X=$GET(ISTART)
SET Y=$GET(ISTOP)
SET ISTOP=X
SET ISTART=Y
+20 SET IDT=0
SET LDA=""
+21 IF ISTOP
SET IDT=ISTOP-.0000001
+22 SET DA=+IENS
+23 ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY
IF DA
SET IDT=$$AAR
IF 'IDT
QUIT LDA
+24 FOR
SET IDT=$ORDER(@AAREF@(IDT),ORD)
IF 'IDT
QUIT
Begin DoDot:1
+25 IF ORD=1
IF IDT>ISTART
SET LDA=""
SET XIT=1
QUIT
+26 IF ORD=-1
IF IDT<ISTART
SET LDA=""
SET XIT=1
QUIT
+27 SET DA=0
+28 FOR
SET DA=$ORDER(@AAREF@(IDT,DA))
IF 'DA
QUIT
Begin DoDot:2
+29 DO DATA(IENS,DA,+$GET(XCNT))
+30 ; TRANSACTION LIMIT
IF NUM=MAX
SET LDA=DA
SET XIT=1
IF '$$AAMORE
SET LDA=""
+31 QUIT
End DoDot:2
IF $GET(XIT)
QUIT
+32 QUIT
End DoDot:1
IF $GET(XIT)
QUIT
+33 QUIT LDA
+34 ;
AAR() ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY
+1 NEW %,X,Y,XIT
+2 SET %=$$AAVAL(FIEN,DAS)
IF '$LENGTH(%)
QUIT ""
+3 SET IDT=$PIECE(%,B,5)
IF 'IDT
QUIT ""
+4 FOR
SET DA=$ORDER(@AAREF@(IDT,DA))
IF 'DA
QUIT
Begin DoDot:1
+5 DO DATA(IENS,DA,+$GET(XCNT))
+6 IF NUM=MAX
SET LDA=DA
SET IDT=""
SET XIT=""
IF '$$AAMORE
SET LDA=""
+7 QUIT
End DoDot:1
IF $GET(XIT)
QUIT
+8 QUIT IDT
+9 ;
AAMORE() ; RETURN A '1' IF MORE ITERATION IS POSSIBLE
+1 NEW X
+2 IF $ORDER(@AAREF@(IDT,DA))
QUIT 1
+3 SET X=$ORDER(@AAREF@(IDT),ORD)
IF 'X
QUIT 0
+4 IF $ORDER(@AAREF@(X,0))
QUIT 1
+5 QUIT 0
+6 ;
AAVAL(FIEN,DAS) ; GIVEN A FILE AND DAS, RETURN INFO NECESSARY TO RE-CREATE THE 'AA' INDEX
+1 NEW DATE,IDT,DFN,TYPE,VIEN,%,OREF,CREF,DA,IENS
+2 IF '$DATA(^DD(FIEN,.01,0))
QUIT ""
+3 SET IENS=$$IENS^BMXADOV($GET(DAS))
IF IENS=U
QUIT ""
+4 SET OREF=$$ROOT^DILFD(FIEN,IENS)
IF '$LENGTH(OREF)
QUIT ""
+5 SET CREF=$$CREF^DILF(OREF)
IF '$LENGTH(CREF)
QUIT ""
+6 SET DA=+IENS
IF '$DATA(@CREF@(DA))
QUIT ""
+7 IF FIEN=9000010
SET DFN=$PIECE(@CREF@(DA,0),U,5)
SET VIEN=DA
+8 IF '$TEST
SET DFN=$PIECE(@CREF@(DA,0),U,2)
SET VIEN=$PIECE(@CREF@(DA,0),U,3)
+9 IF $DATA(^DPT(DFN,0))
IF $DATA(^AUPNVSIT(VIEN,0))
+10 IF '$TEST
QUIT ""
+11 SET DATE=+$PIECE($GET(^AUPNVSIT(VIEN,0)),U)
IF 'DATE
QUIT ""
+12 SET IDT=(9999999-(DATE\1))
+13 SET %=$PIECE(DATE,".",2)
IF %
SET IDT=+(IDT_"."_%)
IF 'IDT
QUIT ""
+14 SET X=OREF_"""AA"")"
SET %=$QUERY(@X)
IF %=""
QUIT ""
+15 SET TYPE=""
IF $LENGTH(%,C)=5
SET TYPE=$PIECE(@CREF@(DA,0),U)
+16 QUIT X_B_DA_B_DFN_B_TYPE_B_IDT
+17 ;
AAP() ;EP - ITERATOR FOR PROBLEM FILE: AA INDEX
+1 IF '$DATA(^AUPNPROB("AA",+$GET(START)))
QUIT ""
+2 NEW LOC,PNUM,DFN,IEN
+3 SET LOC=0
SET DFN=START
+4 FOR
SET LOC=$ORDER(^AUPNPROB("AA",DFN,LOC))
IF 'LOC
QUIT
Begin DoDot:1
+5 SET PNUM=""
+6 FOR
SET PNUM=$ORDER(^AUPNPROB("AA",DFN,LOC,PNUM))
IF PNUM=""
QUIT
Begin DoDot:2
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^AUPNPROB("AA",DFN,LOC,PNUM,IEN))
IF 'IEN
QUIT
DO DATA(",",IEN,+$GET(XCNT))
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT ""
+12 ;
TESTID(DA) ; TEST IDENTIFIERS
+1 NEW %,Y,SEX
+2 SET %=$GET(^DIZ(2160010,+$GET(DA),0))
IF '$LENGTH(%)
QUIT ""
+3 SET SEX=$PIECE(%,U,2)
IF '$LENGTH(SEX)
SET SEX="??"
+4 SET Y=$PIECE(%,U,3)
XECUTE ^DD("DD")
+5 QUIT (SEX_" "_Y)
+6 ;
