AGGWDISP ;VNGT/HS/ALA-Build Window Display ; 09 Apr 2010 7:57 AM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
BLD(DATA,DEF,DFN) ; EP -- AGG BUILD WINDOW DISPLAY
;
;
NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,SECFILE,SECFLD,RET,VAL1,VAL2
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGWDISP",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
I AGIEN=0 S BMXSEC="RPC Failed: Passed in window name "_DEF_" not found" Q
;
S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,AGIEN,0),U,14)
S HEADR="",HDATA=""
S AGCN=0
F S AGCN=$O(^AGG(9009068.3,AGIEN,10,AGCN)) Q:'AGCN D
. I $P(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'="" Q
. S AGDATA=$G(^AGG(9009068.3,AGIEN,10,AGCN,0))
. S FLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,7)
. S RET=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,2)
. S TYPE=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
. S CODE=$P(AGDATA,U,7),HDR=$P(AGDATA,U,2)
. S DEXEC=$G(^AGG(9009068.3,AGIEN,10,AGCN,8))
. I TYPE="M" S VALUE=""
. I TYPE="T" D
.. I DEXEC'="" D Q
... S VAL=""
... I DEXEC'["DQTY" X DEXEC Q
... S DQTY="I" X DEXEC S VAL=VALUE_$C(28)
... S DQTY="E" X DEXEC S VALUE=VAL_VALUE
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"I")_$C(28)_$$GET1^DIQ(FILE,DFN_",",FLD,"E") Q
.. S VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I")_$C(28)_$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"E")
. I (TYPE="C")!(TYPE="K") D
.. I DEXEC'="" D Q
... S VAL=""
... I DEXEC'["DQTY" X DEXEC Q
... S DQTY="I" X DEXEC S VAL=VALUE_$C(28)
... S DQTY="E" X DEXEC S VALUE=VAL_VALUE
.. I FLD'="" D Q
... S VAL1=$$GET1^DIQ(FILE,DFN_",",FLD,"I") I VAL1="" Q
... S VAL2=$O(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,"")) I VAL2="" Q
... S VAL2=$P(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
... S VALUE=VAL1_$C(28)_VAL2
.. S VAL1=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I") I VAL1="" Q
.. S VAL2=$O(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,"")) I VAL2="" Q
.. S VAL2=$P(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
.. S VALUE=VAL1_$C(28)_VAL2
. I TYPE="X"!(TYPE="N") D
.. NEW TYPE
.. I DEXEC'="" X DEXEC Q
.. I FLD'="",FLD=.001 S VALUE=DFN Q
.. I FLD'="",RET="I" D Q
... S VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"I") Q
... S VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I")
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"E") Q
.. S VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"E")
. I TYPE="D" D
.. I DEXEC'="" X DEXEC Q
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE) Q
.. S VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE)
. I TYPE="W" D
.. NEW FL,FD
.. K ARRAY S VALUE=""
.. I DEXEC'="" X DEXEC
.. I DEXEC="" D
... I FLD'="" D GETS^DIQ(FILE,DFN_",",FLD,"E","ARRAY") Q
... D GETS^DIQ(SECFILE,DFN_",",SECFLD,"E","ARRAY")
.. S FL=$O(ARRAY("")) I FL="" Q
.. S FD=$O(ARRAY(FL,DFN_",","")) I FD="" Q
.. S AN=0,TXT=ARRAY(FL,DFN_",",FD,"E") I TXT="" Q
.. K @TXT@("E")
.. F S AN=$O(@TXT@(AN)) Q:AN="" S VALUE=VALUE_@TXT@(AN)_$C(10)
. S HEADR=HEADR_HDR_"^"
. S HDATA=HDATA_$G(VALUE)_"^",VALUE=""
S HEADR=$$TKO^AGGUL1(HEADR,"^"),HDATA=$$TKO^AGGUL1(HDATA,"^")
S @DATA@(II)=HEADR_$C(30)
I $$STRIP^XLFSTR(HDATA,$C(28)_"^")'="" S II=II+1,@DATA@(II)=HDATA_$C(30)
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,@DATA@(II)=$C(31)
Q
;
CMP(DFN,WHICH,PART) ;EP - Get component part
; Input
; DFN - Patient IEN
; PART - Part of name (1=Last, 2=First, 3=Middle, 4=Prefix, 5=Suffix, 6=Degree
; WHICH - Piece of "NAME" node corresponding to type of component
; 1=Patient Name, 2=NOK Name, 3=NOK2 Name, 4=Father's Name, 5=Mother's Name
; 6=Mother's Maiden Name, 7=EC Name, 8=EC2 Name, 9=Designee name
; ALT - Alternate place for the data in NODE;PEC format
;
NEW IEN,ALT,REF,NOD,PEC,VALUE,NAME,RESULT
S RESULT=""
I DFN="" Q RESULT
S IEN=$P($G(^DPT(DFN,"NAME")),"^",WHICH)
S ALT="0;1^.21;1^.211;1^.24;1^.24;2^.24;3^.33;1^.331;1^.34;1"
I $G(IEN)'="" S RESULT=$P($G(^VA(20,IEN,1)),"^",PART) I RESULT="" S IEN=""
I $G(IEN)="" D
. S REF=$P(ALT,"^",WHICH),NOD=$P(REF,";",1),PEC=$P(REF,";",2)
. S VALUE=$P($G(^DPT(DFN,NOD)),"^",PEC)
. K NAME
. S NAME=VALUE
. D STDNAME^XLFNAME(.NAME,"FC")
. S RESULT=$S(PART=1:NAME("FAMILY"),PART=2:NAME("GIVEN"),PART=3:NAME("MIDDLE"),PART=4:NAME("SUFFIX"),1:"")
Q RESULT
;
MUL(DFN,FILE,TFLD,LFLD,VAL) ;EP - Returns most recent (last entered) data from a multiple
; Input
; FILE - File Number
; TFLD - Top level field number that references the lower fields
; LFLD - Lower level field number where data resides
; DFN - Patient IEN
; VAL - "I" for internal value, "E" for external value, "B" for both (pair) value, "D" for dates
;
NEW DA,IENS,GLBREF,ARR,RESULT,SBFIL,NAM,REF,NOD
S GLBREF=$$ROOT^DILFD(FILE,"",0),RESULT=""
F NAM="GLOBAL SUBSCRIPT LOCATION","SPECIFIER" D FIELD^DID(FILE,TFLD,"",NAM,"ARR")
S NOD=$P($G(ARR("GLOBAL SUBSCRIPT LOCATION")),";",1),SBFIL=$G(ARR("SPECIFIER"))
S SBFIL=$$STRIP^XLFSTR(SBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I $G(DFN)="" Q RESULT
S REF=GLBREF_DFN_","_NOD_")"
S DA=$O(@REF@("A"),-1) I DA=0!(DA="") Q RESULT
S DA(1)=DFN,IENS=$$IENS^DILF(.DA)
I VAL="D" S RESULT=$$GET1^DIQ(SBFIL,IENS,LFLD,"I"),RESULT=$$FMTE^AGGUL1(RESULT) Q RESULT
I VAL'="B" S RESULT=$$GET1^DIQ(SBFIL,IENS,LFLD,VAL)
I VAL="B" S RESULT=$$GET1^DIQ(SBFIL,IENS,LFLD,"I")_$C(28)_$$GET1^DIQ(SBFIL,IENS,LFLD,"E")
Q RESULT
AGGWDISP ;VNGT/HS/ALA-Build Window Display ; 09 Apr 2010 7:57 AM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
BLD(DATA,DEF,DFN) ; EP -- AGG BUILD WINDOW DISPLAY
+1 ;
+2 ;
+3 NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
+4 NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,SECFILE,SECFLD,RET,VAL1,VAL2
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("AGGWDISP",UID))
+7 KILL @DATA
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER"
+10 ;
+11 SET AGIEN=$$FIND1^DIC(9009068.3,"","BX",DEF,"","","ERROR")
+12 IF AGIEN=0
SET BMXSEC="RPC Failed: Passed in window name "_DEF_" not found"
QUIT
+13 ;
+14 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,14)
+15 SET HEADR=""
SET HDATA=""
+16 SET AGCN=0
+17 FOR
SET AGCN=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN))
IF 'AGCN
QUIT
Begin DoDot:1
+18 IF $PIECE(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'=""
QUIT
+19 SET AGDATA=$GET(^AGG(9009068.3,AGIEN,10,AGCN,0))
+20 SET FLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1)
SET SECFLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,7)
+21 SET RET=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,2)
+22 SET TYPE=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
+23 SET CODE=$PIECE(AGDATA,U,7)
SET HDR=$PIECE(AGDATA,U,2)
+24 SET DEXEC=$GET(^AGG(9009068.3,AGIEN,10,AGCN,8))
+25 IF TYPE="M"
SET VALUE=""
+26 IF TYPE="T"
Begin DoDot:2
+27 IF DEXEC'=""
Begin DoDot:3
+28 SET VAL=""
+29 IF DEXEC'["DQTY"
XECUTE DEXEC
QUIT
+30 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+31 SET DQTY="E"
XECUTE DEXEC
SET VALUE=VAL_VALUE
End DoDot:3
QUIT
+32 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"I")_$CHAR(28)_$$GET1^DIQ(FILE,DFN_",",FLD,"E")
QUIT
+33 SET VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I")_$CHAR(28)_$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"E")
End DoDot:2
+34 IF (TYPE="C")!(TYPE="K")
Begin DoDot:2
+35 IF DEXEC'=""
Begin DoDot:3
+36 SET VAL=""
+37 IF DEXEC'["DQTY"
XECUTE DEXEC
QUIT
+38 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+39 SET DQTY="E"
XECUTE DEXEC
SET VALUE=VAL_VALUE
End DoDot:3
QUIT
+40 IF FLD'=""
Begin DoDot:3
+41 SET VAL1=$$GET1^DIQ(FILE,DFN_",",FLD,"I")
IF VAL1=""
QUIT
+42 SET VAL2=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,""))
IF VAL2=""
QUIT
+43 SET VAL2=$PIECE(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
+44 SET VALUE=VAL1_$CHAR(28)_VAL2
End DoDot:3
QUIT
+45 SET VAL1=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I")
IF VAL1=""
QUIT
+46 SET VAL2=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,""))
IF VAL2=""
QUIT
+47 SET VAL2=$PIECE(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
+48 SET VALUE=VAL1_$CHAR(28)_VAL2
End DoDot:2
+49 IF TYPE="X"!(TYPE="N")
Begin DoDot:2
+50 NEW TYPE
+51 IF DEXEC'=""
XECUTE DEXEC
QUIT
+52 IF FLD'=""
IF FLD=.001
SET VALUE=DFN
QUIT
+53 IF FLD'=""
IF RET="I"
Begin DoDot:3
+54 SET VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"I")
QUIT
+55 SET VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I")
End DoDot:3
QUIT
+56 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"E")
QUIT
+57 SET VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"E")
End DoDot:2
+58 IF TYPE="D"
Begin DoDot:2
+59 IF DEXEC'=""
XECUTE DEXEC
QUIT
+60 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,DFN_",",FLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
QUIT
+61 SET VALUE=$$GET1^DIQ(SECFILE,DFN_",",SECFLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
End DoDot:2
+62 IF TYPE="W"
Begin DoDot:2
+63 NEW FL,FD
+64 KILL ARRAY
SET VALUE=""
+65 IF DEXEC'=""
XECUTE DEXEC
+66 IF DEXEC=""
Begin DoDot:3
+67 IF FLD'=""
DO GETS^DIQ(FILE,DFN_",",FLD,"E","ARRAY")
QUIT
+68 DO GETS^DIQ(SECFILE,DFN_",",SECFLD,"E","ARRAY")
End DoDot:3
+69 SET FL=$ORDER(ARRAY(""))
IF FL=""
QUIT
+70 SET FD=$ORDER(ARRAY(FL,DFN_",",""))
IF FD=""
QUIT
+71 SET AN=0
SET TXT=ARRAY(FL,DFN_",",FD,"E")
IF TXT=""
QUIT
+72 KILL @TXT@("E")
+73 FOR
SET AN=$ORDER(@TXT@(AN))
IF AN=""
QUIT
SET VALUE=VALUE_@TXT@(AN)_$CHAR(10)
End DoDot:2
+74 SET HEADR=HEADR_HDR_"^"
+75 SET HDATA=HDATA_$GET(VALUE)_"^"
SET VALUE=""
End DoDot:1
+76 SET HEADR=$$TKO^AGGUL1(HEADR,"^")
SET HDATA=$$TKO^AGGUL1(HDATA,"^")
+77 SET @DATA@(II)=HEADR_$CHAR(30)
+78 IF $$STRIP^XLFSTR(HDATA,$CHAR(28)_"^")'=""
SET II=II+1
SET @DATA@(II)=HDATA_$CHAR(30)
+79 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+80 ;
+81 QUIT
+82 ;
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 @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
CMP(DFN,WHICH,PART) ;EP - Get component part
+1 ; Input
+2 ; DFN - Patient IEN
+3 ; PART - Part of name (1=Last, 2=First, 3=Middle, 4=Prefix, 5=Suffix, 6=Degree
+4 ; WHICH - Piece of "NAME" node corresponding to type of component
+5 ; 1=Patient Name, 2=NOK Name, 3=NOK2 Name, 4=Father's Name, 5=Mother's Name
+6 ; 6=Mother's Maiden Name, 7=EC Name, 8=EC2 Name, 9=Designee name
+7 ; ALT - Alternate place for the data in NODE;PEC format
+8 ;
+9 NEW IEN,ALT,REF,NOD,PEC,VALUE,NAME,RESULT
+10 SET RESULT=""
+11 IF DFN=""
QUIT RESULT
+12 SET IEN=$PIECE($GET(^DPT(DFN,"NAME")),"^",WHICH)
+13 SET ALT="0;1^.21;1^.211;1^.24;1^.24;2^.24;3^.33;1^.331;1^.34;1"
+14 IF $GET(IEN)'=""
SET RESULT=$PIECE($GET(^VA(20,IEN,1)),"^",PART)
IF RESULT=""
SET IEN=""
+15 IF $GET(IEN)=""
Begin DoDot:1
+16 SET REF=$PIECE(ALT,"^",WHICH)
SET NOD=$PIECE(REF,";",1)
SET PEC=$PIECE(REF,";",2)
+17 SET VALUE=$PIECE($GET(^DPT(DFN,NOD)),"^",PEC)
+18 KILL NAME
+19 SET NAME=VALUE
+20 DO STDNAME^XLFNAME(.NAME,"FC")
+21 SET RESULT=$SELECT(PART=1:NAME("FAMILY"),PART=2:NAME("GIVEN"),PART=3:NAME("MIDDLE"),PART=4:NAME("SUFFIX"),1:"")
End DoDot:1
+22 QUIT RESULT
+23 ;
MUL(DFN,FILE,TFLD,LFLD,VAL) ;EP - Returns most recent (last entered) data from a multiple
+1 ; Input
+2 ; FILE - File Number
+3 ; TFLD - Top level field number that references the lower fields
+4 ; LFLD - Lower level field number where data resides
+5 ; DFN - Patient IEN
+6 ; VAL - "I" for internal value, "E" for external value, "B" for both (pair) value, "D" for dates
+7 ;
+8 NEW DA,IENS,GLBREF,ARR,RESULT,SBFIL,NAM,REF,NOD
+9 SET GLBREF=$$ROOT^DILFD(FILE,"",0)
SET RESULT=""
+10 FOR NAM="GLOBAL SUBSCRIPT LOCATION","SPECIFIER"
DO FIELD^DID(FILE,TFLD,"",NAM,"ARR")
+11 SET NOD=$PIECE($GET(ARR("GLOBAL SUBSCRIPT LOCATION")),";",1)
SET SBFIL=$GET(ARR("SPECIFIER"))
+12 SET SBFIL=$$STRIP^XLFSTR(SBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+13 IF $GET(DFN)=""
QUIT RESULT
+14 SET REF=GLBREF_DFN_","_NOD_")"
+15 SET DA=$ORDER(@REF@("A"),-1)
IF DA=0!(DA="")
QUIT RESULT
+16 SET DA(1)=DFN
SET IENS=$$IENS^DILF(.DA)
+17 IF VAL="D"
SET RESULT=$$GET1^DIQ(SBFIL,IENS,LFLD,"I")
SET RESULT=$$FMTE^AGGUL1(RESULT)
QUIT RESULT
+18 IF VAL'="B"
SET RESULT=$$GET1^DIQ(SBFIL,IENS,LFLD,VAL)
+19 IF VAL="B"
SET RESULT=$$GET1^DIQ(SBFIL,IENS,LFLD,"I")_$CHAR(28)_$$GET1^DIQ(SBFIL,IENS,LFLD,"E")
+20 QUIT RESULT
