AGGWTBLK ;VNGT/HS/ALA-WINDOW DEFINITION TABLE LOOKUP ; 07 Apr 2010 4:06 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;;
;
Q
;
LKP(DATA,FNBR,VALUE,SCREEN) ;EP -- AGG WINDOW TABLE LOOKUP
;
;Input
; FNBR - File number to look up value
; VALUE - Value to look up in File number
; SCREEN - If this table has special screening logic
;
NEW UID,II,X,DDATA
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGWTBLK",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWTBLK D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S FNBR=$G(FNBR,""),VALUE=$G(VALUE,"")
I VALUE="" S BMXSEC="RPC Call Failed: No value to look up" Q
I FNBR="" S BMXSEC="RPC Call Failed: No file identified to search for value" Q
;
NEW FILE,FIELD,INDEX,FLAGS,NUMB,JJ,IEN,TEXT,DESC,IGN,SDATA
NEW MAP,HDR,MII,NFLD,TYPE,ERROR,XTLKUT
S FILE=FNBR,NUMB="*",INDEX=""
S SCREEN=$G(SCREEN,""),SCREEN=$TR(SCREEN,"~","^")
S FIELD="FID;-WID"_$$WP(FILE)
S:FNBR=50 FIELD=FIELD_";31"
S:FNBR=9999999.06 FIELD="FID;.04;.05;.07;.12",INDEX="B^C",FLAGS="P"
;S FLAGS=$S(FILE=95.3:"P",1:"MP")
S FLAGS="MP"
I $E(VALUE,1)="`" S FLAGS="AP"
I FNBR=9999999.88 S XTLKUT=1,INDEX="B",FLAGS="P"
;
D FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",INDEX,SCREEN,"","","ERROR")
;
I $D(ERROR)>0 S BMXSEC="RPC Call Failed: "_$G(ERROR("DIERR",1,"TEXT",1)) Q
;
S DDATA=$NA(^TMP("DILIST",UID))
S MAP=$G(@DDATA@(0,"MAP"))
I MAP="" S @DATA@(II)="T00015IEN^T00030TEXT^T00120DESCRIPTION"_$C(30)
I MAP'="" D
. S HDR=""
. F MII=1:1:$L(MAP,"^") D
.. I $P(MAP,"^",MII)="IEN" S HDR=HDR_"T00015IEN^" Q
.. I $P(MAP,"^",MII)[".01" D CHK(.01) S HDR=HDR_TYPE_"^" Q
.. I FNBR=9999999.05,$P(MAP,"^",MII)="FID(.08)" S IGN=MII Q
.. S NFLD=$P(MAP,"^",MII)
.. I NFLD["FID(" S NFLD=$P($P(NFLD,"FID(",2),")",1) D CHK(NFLD) S HDR=HDR_TYPE_"^" Q
.. D CHK(NFLD) S HDR=HDR_TYPE_"^"
. I FILE=80.1!(FILE=80)!(FILE=81) S HDR=HDR_"T00060LOOK_DISPLAY"
. I FILE=9999999.06 D
.. S HDR=HDR_"T00120LOOK_DISPLAY"
.. S HDR=$TR(HDR," ","_")
. S HDR=$$TKO^AGGUL1(HDR,"^"),HDR=$TR(HDR," ","_")
. S @DATA@(II)=HDR_$C(30)
. I FNBR=9000003.1 D
.. S $P(@DATA@(II),U,1)="T00015AGGPLIEN",$P(@DATA@(II),U,2)="T00035AGGPIHLD",$P(@DATA@(II),U,5)="T00020AGGPINUM"
.. S $P(@DATA@(II),U,3)="I00010AGGPTIINS"
I FNBR=9999999.06 D PRST
S JJ=0
F S JJ=$O(@DDATA@(JJ)) Q:'JJ D
. I MAP="" D
.. S IEN=$P(@DDATA@(JJ,0),U,1)
.. S TEXT=$P(@DDATA@(JJ,0),U,2)
.. S DESC=""
.. S FLD=$S(FNBR=80:3,FNBR=80.1:4,FNBR=81:2,FNBR=81:2,FNBR=9999999.31:.02,1:"")
.. I FLD'="" S DESC=$$GET1^DIQ(FNBR,IEN,FLD,"E")
.. S II=II+1,@DATA@(II)=IEN_"^"_TEXT_"^"_DESC_$C(30)
. I MAP'="" D
.. NEW IEN,TEXT,DESC,QFL
.. S IEN=$P(@DDATA@(JJ,0),U,1),QFL=0
.. S TEXT=$P(@DDATA@(JJ,0),U,2)
.. I TEXT?.N D
... S DESC=$$GET1^DIQ(FNBR,IEN,.01,"E")
... S $P(@DDATA@(JJ,0),U,2)=DESC
.. I FILE=80.1!(FILE=80)!(FILE=81) S @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$P(@DDATA@(JJ,0),U,2)_"-"_$P(@DDATA@(JJ,0),U,3)
.. I FILE=9999999.06 D Q:QFL
... I $P($G(^DIC(4,IEN,0)),U,11)="L" S QFL=1 Q
... S @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$P(@DDATA@(JJ,0),U,2)_"-"_$P(@DDATA@(JJ,0),U,3)_"-"_$P(@DDATA@(JJ,0),U,4)
.. I $G(IGN) S II=II+1,@DATA@(II)=$P(@DDATA@(JJ,0),U,1,(IGN-1))_$C(30) Q
.. S II=II+1,@DATA@(II)=@DDATA@(JJ,0)_$C(30)
.. I FILE=9000003.1 D
... I $P(^AUPN3PPH(IEN,0),U,3)'="" S $P(@DATA@(II),U,3)=$P(^AUPN3PPH(IEN,0),U,3)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,^TMP("AGGWTBLK",UID,II)=$C(31)
Q
;
CHK(BFLD) ;EP - Check for definition of a field
NEW DLEN
D FIELD^DID(FNBR,BFLD,"","TYPE","BQX")
D FIELD^DID(FNBR,BFLD,"","FIELD LENGTH","BQX")
D FIELD^DID(FNBR,BFLD,"","LABEL","BQX")
S TYPE=$S(BQX("TYPE")["DATE":"D",1:"T")
S DLEN=BQX("FIELD LENGTH")+5
S TYPE=TYPE_$E("00000",$L(DLEN)+1,5)_DLEN_BQX("LABEL")
K BQX
Q
;
TAB(DATA,FNBR) ;EP -- AGG GET WINDOW DEF TABLE
;Input
; FNBR - File number to look up value
;
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGWTBLK",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWTBLK D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S FNBR=$G(FNBR,""),IACT=""
I FNBR="" S BMXSEC="RPC Call Failed: No file identified to search for value" Q
;
I FNBR=9999999.25 D TBL(.DATA,FNBR,"0;3","I") Q
;
I FNBR=10 S IACT=".02;1"
I FNBR=10.2 S IACT=".02;1"
;
I FNBR=40.7 S IACT=""
I FNBR=11 S IACT=""
I FNBR=23 S IACT=""
I FNBR=9999999.78 S IACT=""
I FNBR=9999999.75 S IACT=""
I FNBR=9999999.77 S IACT=""
I FNBR=9999999.32 S IACT=""
I FNBR=9999999.02 S IACT=""
I FNBR=9999999.99 S IACT=""
I FNBR=9999999.36 S IACT="0;6"
;
I FNBR=5 D ST(DATA,5) Q
I FNBR="PL9999999.18" D PLN(.DATA,"9999999.18") Q
I FNBR="LG9000030" D LEG(.DATA,"9000030") Q
I FNBR="CV9999999.65" D COV(.DATA,"9999999.65") Q
;
I FNBR="PN9999999.18" D MEDPD(.DATA,"9999999.18") Q
;
I FNBR=9999999.03 D TBL(.DATA,FNBR,"0;4","Y") Q
;
D TBL^AGGUTB(.DATA,FNBR,IACT)
Q
;
CLS(DATA,FILE) ; EP - Get Clinical Classifications
NEW IEN,NAME,DESC
S @DATA@(II)="I00010IEN^T00160"_$C(30)
S IEN=0
F S IEN=$O(^BKMV(FILE,IEN)) Q:'IEN D
. S NAME=$P(^BKMV(FILE,IEN,0),U,1)
. S DESC=$P(^BKMV(FILE,IEN,0),U,2)
. S II=II+1,@DATA@(II)=IEN_U_NAME_"-"_DESC_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
PLN(DATA,FILE) ; EP - Get Plan names
NEW IEN,NAME
S @DATA@(II)="I00010IEN^T00030"_$C(30)
S IEN=0
F S IEN=$O(^AUTNINS(IEN)) Q:'IEN D
. I $P($G(^AUTNINS(IEN,2)),U,1)'="D",($P($G(^AUTNINS(IEN,2)),U,1)'="K") Q
. ;I $P($G(^AUTNINS(IEN,1)),U,7)'=1 Q
. S NAME=$P(^AUTNINS(IEN,0),U,1)
. S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;S DIC("S")="I $P($G(^(2)),""^"",1)=""D""!($P($G(^(2)),""^"",1)=""K"")"
Q
;
COV(DATA,FILE) ; EP - Get Coverage types
NEW IEN,NAME,INS
S @DATA@(II)="I00010IEN^T00030^I00010AGGPIINS"_$C(30)
S IEN=0
F S IEN=$O(^AUTTPIC(IEN)) Q:'IEN D
. I $P($G(^AUTTPIC(IEN,0)),U,6)'="" Q
. S NAME=$P(^AUTTPIC(IEN,0),U,1),INS=$P(^AUTTPIC(IEN,0),U,2) I INS="" Q
. S II=II+1,@DATA@(II)=IEN_U_NAME_U_INS_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
LEG(DATA,FILE) ; EP - Get
NEW IEN,NAME
S @DATA@(II)="I00010IEN^T00030"_$C(30)
S IEN=0
F S IEN=$O(^AUPNELM(IEN)) Q:'IEN D
. I $P($G(^AUPNELM(IEN,0)),U,2)'["N" Q
. S NAME=$P(^AUPNELM(IEN,0),U,1)
. S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
MEDPD(DATA,FILE) ; EP - Get Insurance Table for Part D
NEW IIEN,IENS,II
S II=0
S @DATA@(II)="I00010IEN^T00030"_$C(30) ;NAME^T00030STREET^T00015CITY^T00030STATE^T00010ZIP^T00025TYPE^T00013PHONE"_$C(30)
S IIEN=0
F S IIEN=$O(^AUTNINS(IIEN)) Q:'IIEN D
. I $P($G(^AUTNINS(IIEN,1)),"^",7)=0 Q
. Q:$P($G(^AUTNINS(IIEN,2)),U)'="MD"
. S INS=^AUTNINS(IIEN,0)
. S ST=$P(INS,U,4) I ST'="" S ST=$P(^DIC(5,ST,0),U,1)
. S II=II+1,@DATA@(II)=IIEN_U_$P(INS,U,1)_$C(30) ;_U_$P(INS,U,2)_U_$P(INS,U,3)_U_ST_U_$P(INS,U,5)_U_$P($G(^AUTNINS(IIEN,2)),U,1)_U_$P(INS,U,6)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ST(DATA,FILE) ; EP - Get State names
NEW IEN,NAME,CODE,FULL
S @DATA@(II)="I00010IEN^T00035"_$C(30)
S IEN=0
F S IEN=$O(^DIC(5,IEN)) Q:'IEN D
. S FULL=$P(^DIC(5,IEN,0),U,1),CODE=$P(^DIC(5,IEN,0),U,2)
. S NAME=CODE_"-"_FULL
. S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
Q
;
WP(FILE) ; Exclude identifiers that are word processing fields
;
NEW ID,TYPE,WPFLD
S ID="",WPFLD=""
F S ID=$O(^DD(FILE,0,"ID",ID)) Q:ID="" D
. S TYPE=$P($G(^DD(FILE,ID,0)),"^",2) Q:'TYPE
. I $P($G(^DD(+TYPE,.01,0)),"^",2)["W" S WPFLD=WPFLD_";-"_ID
Q WPFLD
;
TBL(DATA,FILE,INAC,VALS) ;EP - Get table data if generic table lookup cannot
; be used since inactive field may have length if active
;
;Input
; FILE - FileMan file number where table resides
; INAC - Location of inactive field to check, contains
; the node and piece in 'NODE;PIECE' format
; VALS - Value(s) that constitute an inactive record (delimited by a comma)
;
;Description
; Return the values in a table
;
NEW GLBREF,LENGTH,DLEN,INACFLG,PC,VAL,VFVAL
;
I '$$VFILE^DILFD(FILE) S BMXSEC="RPC Call Failed: Table doesn't exist in RPMS" Q
;
S GLBREF=$$ROOT^DILFD(FILE,"",1)
S LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S @DATA@(II)="I00010IEN^T"_DLEN_$C(30)
;
I INAC'="" S NODE=$P(INAC,";",1),PEC=$P(INAC,";",2)
S IEN=0
F S IEN=$O(@GLBREF@(IEN)) Q:'IEN D
. I $G(@GLBREF@(IEN,0))="" Q
. I INAC'="" S INACFLG=0 D Q:INACFLG
.. S VFVAL=$P($G(@GLBREF@(IEN,NODE)),"^",PEC)
.. F PC=1:1:$L(VALS,",") S VAL=$P(VALS,",",PC) I VFVAL=VAL S INACFLG=1 Q
. S II=II+1,@DATA@(II)=IEN_"^"_$$GET1^DIQ(FILE,IEN_",",.01,"E")_$C(30)
;
DONE S II=II+1,@DATA@(II)=$C(31)
Q
;
PRST ; Presort results so that matching SERVICE UNIT (and, if possible, AREA) are listed 1st
NEW SVCUN,DAREA,SEL,ZERO,MAP,CT,AREA,SVCU,NN
S SVCUN=$$GET1^DIQ(9999999.06,DUZ(2)_",",.05,"E")
S DAREA=$$GET1^DIQ(9999999.06,DUZ(2)_",",.04,"E")
S SDATA=$NA(^TMP("AGGVFSORT",UID))
S SEL=""
K AGGAS,AGGSA,AGGSORT
S JJ=0 F S JJ=$O(@DDATA@(JJ)) Q:'JJ D Q:SEL
. S AREA=$P(@DDATA@(JJ,0),U,3),SVCU=$P(@DDATA@(JJ,0),U,4)
. S:AREA="" AREA="unknown" S:SVCU="" SVCU="unknown"
. S AGGAS(AREA,SVCU,JJ)="",AGGSA(SVCU,AREA,JJ)=""
I DAREA'="",SVCUN'="",$D(AGGAS(DAREA,SVCUN)) D
. S SEL=$O(AGGAS(DAREA,SVCUN,"")),AGGSORT("@",SEL)=@DDATA@(SEL,0)
I 'SEL,SVCUN'="",$D(AGGSA(SVCUN)) D
. S AREA=$O(AGGSA(SVCUN,"")),SEL=$O(AGGSA(SVCUN,AREA,"")),AGGSORT("@",SEL)=@DDATA@(SEL,0)
I 'SEL,DAREA'="",$D(AGGAS(DAREA)) D
. S SVCU=$O(AGGAS(DAREA,"")),SEL=$O(AGGAS(DAREA,SVCU,"")),AGGSORT("@",SEL)=@DDATA@(SEL,0)
I 'SEL,$D(AGGAS) D
. S AREA=$O(AGGAS("")),SVCU=$O(AGGAS(AREA,"")),SEL=$O(AGGAS(AREA,SVCU,"")),AGGSORT("@",SEL)=@DDATA@(SEL,0)
K AGGAS,AGGSA
S JJ=0,CT=0
F S JJ=$O(@DDATA@(JJ)) Q:'JJ I JJ'=SEL D
. S CT=CT+1,AGGSORT(CT,JJ)=@DDATA@(JJ,0)
S ZERO=$G(@DDATA@(0))
S MAP=$G(@DDATA@(0,"MAP"))
K @DDATA
S @DDATA@(0)=ZERO
S @DDATA@(0,"MAP")=MAP
S CT=0,AREA="@",NN=0
F S NN=$O(AGGSORT(AREA,NN)) Q:NN="" D
. S CT=CT+1,@DDATA@(CT,0)=AGGSORT(AREA,NN)
. K AGGSORT(AREA,NN)
S AREA=""
F S AREA=$O(AGGSORT(AREA)) Q:AREA="" D
. S NN=""
. F S NN=$O(AGGSORT(AREA,NN)) Q:NN="" D
.. S CT=CT+1,@DDATA@(CT,0)=AGGSORT(AREA,NN)
K AGGSORT
Q
AGGWTBLK ;VNGT/HS/ALA-WINDOW DEFINITION TABLE LOOKUP ; 07 Apr 2010 4:06 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;;
+3 ;
+4 QUIT
+5 ;
LKP(DATA,FNBR,VALUE,SCREEN) ;EP -- AGG WINDOW TABLE LOOKUP
+1 ;
+2 ;Input
+3 ; FNBR - File number to look up value
+4 ; VALUE - Value to look up in File number
+5 ; SCREEN - If this table has special screening logic
+6 ;
+7 NEW UID,II,X,DDATA
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("AGGWTBLK",UID))
+10 KILL @DATA
+11 ;
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWTBLK D UNWIND^%ZTER"
+14 ;
+15 SET FNBR=$GET(FNBR,"")
SET VALUE=$GET(VALUE,"")
+16 IF VALUE=""
SET BMXSEC="RPC Call Failed: No value to look up"
QUIT
+17 IF FNBR=""
SET BMXSEC="RPC Call Failed: No file identified to search for value"
QUIT
+18 ;
+19 NEW FILE,FIELD,INDEX,FLAGS,NUMB,JJ,IEN,TEXT,DESC,IGN,SDATA
+20 NEW MAP,HDR,MII,NFLD,TYPE,ERROR,XTLKUT
+21 SET FILE=FNBR
SET NUMB="*"
SET INDEX=""
+22 SET SCREEN=$GET(SCREEN,"")
SET SCREEN=$TRANSLATE(SCREEN,"~","^")
+23 SET FIELD="FID;-WID"_$$WP(FILE)
+24 IF FNBR=50
SET FIELD=FIELD_";31"
+25 IF FNBR=9999999.06
SET FIELD="FID;.04;.05;.07;.12"
SET INDEX="B^C"
SET FLAGS="P"
+26 ;S FLAGS=$S(FILE=95.3:"P",1:"MP")
+27 SET FLAGS="MP"
+28 IF $EXTRACT(VALUE,1)="`"
SET FLAGS="AP"
+29 IF FNBR=9999999.88
SET XTLKUT=1
SET INDEX="B"
SET FLAGS="P"
+30 ;
+31 DO FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",INDEX,SCREEN,"","","ERROR")
+32 ;
+33 IF $DATA(ERROR)>0
SET BMXSEC="RPC Call Failed: "_$GET(ERROR("DIERR",1,"TEXT",1))
QUIT
+34 ;
+35 SET DDATA=$NAME(^TMP("DILIST",UID))
+36 SET MAP=$GET(@DDATA@(0,"MAP"))
+37 IF MAP=""
SET @DATA@(II)="T00015IEN^T00030TEXT^T00120DESCRIPTION"_$CHAR(30)
+38 IF MAP'=""
Begin DoDot:1
+39 SET HDR=""
+40 FOR MII=1:1:$LENGTH(MAP,"^")
Begin DoDot:2
+41 IF $PIECE(MAP,"^",MII)="IEN"
SET HDR=HDR_"T00015IEN^"
QUIT
+42 IF $PIECE(MAP,"^",MII)[".01"
DO CHK(.01)
SET HDR=HDR_TYPE_"^"
QUIT
+43 IF FNBR=9999999.05
IF $PIECE(MAP,"^",MII)="FID(.08)"
SET IGN=MII
QUIT
+44 SET NFLD=$PIECE(MAP,"^",MII)
+45 IF NFLD["FID("
SET NFLD=$PIECE($PIECE(NFLD,"FID(",2),")",1)
DO CHK(NFLD)
SET HDR=HDR_TYPE_"^"
QUIT
+46 DO CHK(NFLD)
SET HDR=HDR_TYPE_"^"
End DoDot:2
+47 IF FILE=80.1!(FILE=80)!(FILE=81)
SET HDR=HDR_"T00060LOOK_DISPLAY"
+48 IF FILE=9999999.06
Begin DoDot:2
+49 SET HDR=HDR_"T00120LOOK_DISPLAY"
+50 SET HDR=$TRANSLATE(HDR," ","_")
End DoDot:2
+51 SET HDR=$$TKO^AGGUL1(HDR,"^")
SET HDR=$TRANSLATE(HDR," ","_")
+52 SET @DATA@(II)=HDR_$CHAR(30)
+53 IF FNBR=9000003.1
Begin DoDot:2
+54 SET $PIECE(@DATA@(II),U,1)="T00015AGGPLIEN"
SET $PIECE(@DATA@(II),U,2)="T00035AGGPIHLD"
SET $PIECE(@DATA@(II),U,5)="T00020AGGPINUM"
+55 SET $PIECE(@DATA@(II),U,3)="I00010AGGPTIINS"
End DoDot:2
End DoDot:1
+56 IF FNBR=9999999.06
DO PRST
+57 SET JJ=0
+58 FOR
SET JJ=$ORDER(@DDATA@(JJ))
IF 'JJ
QUIT
Begin DoDot:1
+59 IF MAP=""
Begin DoDot:2
+60 SET IEN=$PIECE(@DDATA@(JJ,0),U,1)
+61 SET TEXT=$PIECE(@DDATA@(JJ,0),U,2)
+62 SET DESC=""
+63 SET FLD=$SELECT(FNBR=80:3,FNBR=80.1:4,FNBR=81:2,FNBR=81:2,FNBR=9999999.31:.02,1:"")
+64 IF FLD'=""
SET DESC=$$GET1^DIQ(FNBR,IEN,FLD,"E")
+65 SET II=II+1
SET @DATA@(II)=IEN_"^"_TEXT_"^"_DESC_$CHAR(30)
End DoDot:2
+66 IF MAP'=""
Begin DoDot:2
+67 NEW IEN,TEXT,DESC,QFL
+68 SET IEN=$PIECE(@DDATA@(JJ,0),U,1)
SET QFL=0
+69 SET TEXT=$PIECE(@DDATA@(JJ,0),U,2)
+70 IF TEXT?.N
Begin DoDot:3
+71 SET DESC=$$GET1^DIQ(FNBR,IEN,.01,"E")
+72 SET $PIECE(@DDATA@(JJ,0),U,2)=DESC
End DoDot:3
+73 IF FILE=80.1!(FILE=80)!(FILE=81)
SET @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$PIECE(@DDATA@(JJ,0),U,2)_"-"_$PIECE(@DDATA@(JJ,0),U,3)
+74 IF FILE=9999999.06
Begin DoDot:3
+75 IF $PIECE($GET(^DIC(4,IEN,0)),U,11)="L"
SET QFL=1
QUIT
+76 SET @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$PIECE(@DDATA@(JJ,0),U,2)_"-"_$PIECE(@DDATA@(JJ,0),U,3)_"-"_$PIECE(@DDATA@(JJ,0),U,4)
End DoDot:3
IF QFL
QUIT
+77 IF $GET(IGN)
SET II=II+1
SET @DATA@(II)=$PIECE(@DDATA@(JJ,0),U,1,(IGN-1))_$CHAR(30)
QUIT
+78 SET II=II+1
SET @DATA@(II)=@DDATA@(JJ,0)_$CHAR(30)
+79 IF FILE=9000003.1
Begin DoDot:3
+80 IF $PIECE(^AUPN3PPH(IEN,0),U,3)'=""
SET $PIECE(@DATA@(II),U,3)=$PIECE(^AUPN3PPH(IEN,0),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+81 ;
+82 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+83 QUIT
+84 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET ^TMP("AGGWTBLK",UID,II)=$CHAR(31)
+6 QUIT
+7 ;
CHK(BFLD) ;EP - Check for definition of a field
+1 NEW DLEN
+2 DO FIELD^DID(FNBR,BFLD,"","TYPE","BQX")
+3 DO FIELD^DID(FNBR,BFLD,"","FIELD LENGTH","BQX")
+4 DO FIELD^DID(FNBR,BFLD,"","LABEL","BQX")
+5 SET TYPE=$SELECT(BQX("TYPE")["DATE":"D",1:"T")
+6 SET DLEN=BQX("FIELD LENGTH")+5
+7 SET TYPE=TYPE_$EXTRACT("00000",$LENGTH(DLEN)+1,5)_DLEN_BQX("LABEL")
+8 KILL BQX
+9 QUIT
+10 ;
TAB(DATA,FNBR) ;EP -- AGG GET WINDOW DEF TABLE
+1 ;Input
+2 ; FNBR - File number to look up value
+3 ;
+4 NEW UID,II,X
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("AGGWTBLK",UID))
+7 KILL @DATA
+8 ;
+9 SET II=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWTBLK D UNWIND^%ZTER"
+11 ;
+12 SET FNBR=$GET(FNBR,"")
SET IACT=""
+13 IF FNBR=""
SET BMXSEC="RPC Call Failed: No file identified to search for value"
QUIT
+14 ;
+15 IF FNBR=9999999.25
DO TBL(.DATA,FNBR,"0;3","I")
QUIT
+16 ;
+17 IF FNBR=10
SET IACT=".02;1"
+18 IF FNBR=10.2
SET IACT=".02;1"
+19 ;
+20 IF FNBR=40.7
SET IACT=""
+21 IF FNBR=11
SET IACT=""
+22 IF FNBR=23
SET IACT=""
+23 IF FNBR=9999999.78
SET IACT=""
+24 IF FNBR=9999999.75
SET IACT=""
+25 IF FNBR=9999999.77
SET IACT=""
+26 IF FNBR=9999999.32
SET IACT=""
+27 IF FNBR=9999999.02
SET IACT=""
+28 IF FNBR=9999999.99
SET IACT=""
+29 IF FNBR=9999999.36
SET IACT="0;6"
+30 ;
+31 IF FNBR=5
DO ST(DATA,5)
QUIT
+32 IF FNBR="PL9999999.18"
DO PLN(.DATA,"9999999.18")
QUIT
+33 IF FNBR="LG9000030"
DO LEG(.DATA,"9000030")
QUIT
+34 IF FNBR="CV9999999.65"
DO COV(.DATA,"9999999.65")
QUIT
+35 ;
+36 IF FNBR="PN9999999.18"
DO MEDPD(.DATA,"9999999.18")
QUIT
+37 ;
+38 IF FNBR=9999999.03
DO TBL(.DATA,FNBR,"0;4","Y")
QUIT
+39 ;
+40 DO TBL^AGGUTB(.DATA,FNBR,IACT)
+41 QUIT
+42 ;
CLS(DATA,FILE) ; EP - Get Clinical Classifications
+1 NEW IEN,NAME,DESC
+2 SET @DATA@(II)="I00010IEN^T00160"_$CHAR(30)
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^BKMV(FILE,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 SET NAME=$PIECE(^BKMV(FILE,IEN,0),U,1)
+6 SET DESC=$PIECE(^BKMV(FILE,IEN,0),U,2)
+7 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_"-"_DESC_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
PLN(DATA,FILE) ; EP - Get Plan names
+1 NEW IEN,NAME
+2 SET @DATA@(II)="I00010IEN^T00030"_$CHAR(30)
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^AUTNINS(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUTNINS(IEN,2)),U,1)'="D"
IF ($PIECE($GET(^AUTNINS(IEN,2)),U,1)'="K")
QUIT
+6 ;I $P($G(^AUTNINS(IEN,1)),U,7)'=1 Q
+7 SET NAME=$PIECE(^AUTNINS(IEN,0),U,1)
+8 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 ;S DIC("S")="I $P($G(^(2)),""^"",1)=""D""!($P($G(^(2)),""^"",1)=""K"")"
+11 QUIT
+12 ;
COV(DATA,FILE) ; EP - Get Coverage types
+1 NEW IEN,NAME,INS
+2 SET @DATA@(II)="I00010IEN^T00030^I00010AGGPIINS"_$CHAR(30)
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^AUTTPIC(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUTTPIC(IEN,0)),U,6)'=""
QUIT
+6 SET NAME=$PIECE(^AUTTPIC(IEN,0),U,1)
SET INS=$PIECE(^AUTTPIC(IEN,0),U,2)
IF INS=""
QUIT
+7 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_U_INS_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
LEG(DATA,FILE) ; EP - Get
+1 NEW IEN,NAME
+2 SET @DATA@(II)="I00010IEN^T00030"_$CHAR(30)
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^AUPNELM(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNELM(IEN,0)),U,2)'["N"
QUIT
+6 SET NAME=$PIECE(^AUPNELM(IEN,0),U,1)
+7 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
MEDPD(DATA,FILE) ; EP - Get Insurance Table for Part D
+1 NEW IIEN,IENS,II
+2 SET II=0
+3 ;NAME^T00030STREET^T00015CITY^T00030STATE^T00010ZIP^T00025TYPE^T00013PHONE"_$C(30)
SET @DATA@(II)="I00010IEN^T00030"_$CHAR(30)
+4 SET IIEN=0
+5 FOR
SET IIEN=$ORDER(^AUTNINS(IIEN))
IF 'IIEN
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUTNINS(IIEN,1)),"^",7)=0
QUIT
+7 IF $PIECE($GET(^AUTNINS(IIEN,2)),U)'="MD"
QUIT
+8 SET INS=^AUTNINS(IIEN,0)
+9 SET ST=$PIECE(INS,U,4)
IF ST'=""
SET ST=$PIECE(^DIC(5,ST,0),U,1)
+10 ;_U_$P(INS,U,2)_U_$P(INS,U,3)_U_ST_U_$P(INS,U,5)_U_$P($G(^AUTNINS(IIEN,2)),U,1)_U_$P(INS,U,6)_$C(30)
SET II=II+1
SET @DATA@(II)=IIEN_U_$PIECE(INS,U,1)_$CHAR(30)
End DoDot:1
+11 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+12 QUIT
+13 ;
ST(DATA,FILE) ; EP - Get State names
+1 NEW IEN,NAME,CODE,FULL
+2 SET @DATA@(II)="I00010IEN^T00035"_$CHAR(30)
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^DIC(5,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 SET FULL=$PIECE(^DIC(5,IEN,0),U,1)
SET CODE=$PIECE(^DIC(5,IEN,0),U,2)
+6 SET NAME=CODE_"-"_FULL
+7 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_$CHAR(30)
End DoDot:1
+8 QUIT
+9 ;
WP(FILE) ; Exclude identifiers that are word processing fields
+1 ;
+2 NEW ID,TYPE,WPFLD
+3 SET ID=""
SET WPFLD=""
+4 FOR
SET ID=$ORDER(^DD(FILE,0,"ID",ID))
IF ID=""
QUIT
Begin DoDot:1
+5 SET TYPE=$PIECE($GET(^DD(FILE,ID,0)),"^",2)
IF 'TYPE
QUIT
+6 IF $PIECE($GET(^DD(+TYPE,.01,0)),"^",2)["W"
SET WPFLD=WPFLD_";-"_ID
End DoDot:1
+7 QUIT WPFLD
+8 ;
TBL(DATA,FILE,INAC,VALS) ;EP - Get table data if generic table lookup cannot
+1 ; be used since inactive field may have length if active
+2 ;
+3 ;Input
+4 ; FILE - FileMan file number where table resides
+5 ; INAC - Location of inactive field to check, contains
+6 ; the node and piece in 'NODE;PIECE' format
+7 ; VALS - Value(s) that constitute an inactive record (delimited by a comma)
+8 ;
+9 ;Description
+10 ; Return the values in a table
+11 ;
+12 NEW GLBREF,LENGTH,DLEN,INACFLG,PC,VAL,VFVAL
+13 ;
+14 IF '$$VFILE^DILFD(FILE)
SET BMXSEC="RPC Call Failed: Table doesn't exist in RPMS"
QUIT
+15 ;
+16 SET GLBREF=$$ROOT^DILFD(FILE,"",1)
+17 SET LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
+18 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+19 SET @DATA@(II)="I00010IEN^T"_DLEN_$CHAR(30)
+20 ;
+21 IF INAC'=""
SET NODE=$PIECE(INAC,";",1)
SET PEC=$PIECE(INAC,";",2)
+22 SET IEN=0
+23 FOR
SET IEN=$ORDER(@GLBREF@(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+24 IF $GET(@GLBREF@(IEN,0))=""
QUIT
+25 IF INAC'=""
SET INACFLG=0
Begin DoDot:2
+26 SET VFVAL=$PIECE($GET(@GLBREF@(IEN,NODE)),"^",PEC)
+27 FOR PC=1:1:$LENGTH(VALS,",")
SET VAL=$PIECE(VALS,",",PC)
IF VFVAL=VAL
SET INACFLG=1
QUIT
End DoDot:2
IF INACFLG
QUIT
+28 SET II=II+1
SET @DATA@(II)=IEN_"^"_$$GET1^DIQ(FILE,IEN_",",.01,"E")_$CHAR(30)
End DoDot:1
+29 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
PRST ; Presort results so that matching SERVICE UNIT (and, if possible, AREA) are listed 1st
+1 NEW SVCUN,DAREA,SEL,ZERO,MAP,CT,AREA,SVCU,NN
+2 SET SVCUN=$$GET1^DIQ(9999999.06,DUZ(2)_",",.05,"E")
+3 SET DAREA=$$GET1^DIQ(9999999.06,DUZ(2)_",",.04,"E")
+4 SET SDATA=$NAME(^TMP("AGGVFSORT",UID))
+5 SET SEL=""
+6 KILL AGGAS,AGGSA,AGGSORT
+7 SET JJ=0
FOR
SET JJ=$ORDER(@DDATA@(JJ))
IF 'JJ
QUIT
Begin DoDot:1
+8 SET AREA=$PIECE(@DDATA@(JJ,0),U,3)
SET SVCU=$PIECE(@DDATA@(JJ,0),U,4)
+9 IF AREA=""
SET AREA="unknown"
IF SVCU=""
SET SVCU="unknown"
+10 SET AGGAS(AREA,SVCU,JJ)=""
SET AGGSA(SVCU,AREA,JJ)=""
End DoDot:1
IF SEL
QUIT
+11 IF DAREA'=""
IF SVCUN'=""
IF $DATA(AGGAS(DAREA,SVCUN))
Begin DoDot:1
+12 SET SEL=$ORDER(AGGAS(DAREA,SVCUN,""))
SET AGGSORT("@",SEL)=@DDATA@(SEL,0)
End DoDot:1
+13 IF 'SEL
IF SVCUN'=""
IF $DATA(AGGSA(SVCUN))
Begin DoDot:1
+14 SET AREA=$ORDER(AGGSA(SVCUN,""))
SET SEL=$ORDER(AGGSA(SVCUN,AREA,""))
SET AGGSORT("@",SEL)=@DDATA@(SEL,0)
End DoDot:1
+15 IF 'SEL
IF DAREA'=""
IF $DATA(AGGAS(DAREA))
Begin DoDot:1
+16 SET SVCU=$ORDER(AGGAS(DAREA,""))
SET SEL=$ORDER(AGGAS(DAREA,SVCU,""))
SET AGGSORT("@",SEL)=@DDATA@(SEL,0)
End DoDot:1
+17 IF 'SEL
IF $DATA(AGGAS)
Begin DoDot:1
+18 SET AREA=$ORDER(AGGAS(""))
SET SVCU=$ORDER(AGGAS(AREA,""))
SET SEL=$ORDER(AGGAS(AREA,SVCU,""))
SET AGGSORT("@",SEL)=@DDATA@(SEL,0)
End DoDot:1
+19 KILL AGGAS,AGGSA
+20 SET JJ=0
SET CT=0
+21 FOR
SET JJ=$ORDER(@DDATA@(JJ))
IF 'JJ
QUIT
IF JJ'=SEL
Begin DoDot:1
+22 SET CT=CT+1
SET AGGSORT(CT,JJ)=@DDATA@(JJ,0)
End DoDot:1
+23 SET ZERO=$GET(@DDATA@(0))
+24 SET MAP=$GET(@DDATA@(0,"MAP"))
+25 KILL @DDATA
+26 SET @DDATA@(0)=ZERO
+27 SET @DDATA@(0,"MAP")=MAP
+28 SET CT=0
SET AREA="@"
SET NN=0
+29 FOR
SET NN=$ORDER(AGGSORT(AREA,NN))
IF NN=""
QUIT
Begin DoDot:1
+30 SET CT=CT+1
SET @DDATA@(CT,0)=AGGSORT(AREA,NN)
+31 KILL AGGSORT(AREA,NN)
End DoDot:1
+32 SET AREA=""
+33 FOR
SET AREA=$ORDER(AGGSORT(AREA))
IF AREA=""
QUIT
Begin DoDot:1
+34 SET NN=""
+35 FOR
SET NN=$ORDER(AGGSORT(AREA,NN))
IF NN=""
QUIT
Begin DoDot:2
+36 SET CT=CT+1
SET @DDATA@(CT,0)=AGGSORT(AREA,NN)
End DoDot:2
End DoDot:1
+37 KILL AGGSORT
+38 QUIT
