AGGPTPVT ;VNGT/HS/ALA-Private Insurance ; 15 Jul 2010 3:33 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
BLD(DATA,DFN,PIIEN,IINS) ; EP -- AGG BUILD PRIVATE INS
; Input Parameters
; DFN - Patient IEN
; PIIEN - Record IEN
; IINS - Insurer IEN
;
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,IENS,SIENS,PHIEN,DEF,AGGPEC,AGGPINUM
NEW AGGPIMBN
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 DEF="Insurance Edit"
S AGIEN=$O(^AGG(9009068.3,"B",DEF,""))
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)
;
I $G(PIIEN)'="" S PHIEN=$P($G(^AUPNPRVT(DFN,11,PIIEN,0)),U,8)
I $G(IINS)'="" S AGGIINS=IINS
I $G(IINS)="" S AGGIINS=$P($G(^AUPNPRVT(DFN,11,PIIEN,0)),U,1)
;
NEW DA,IENS
I $G(PIIEN)'="" S DA(1)=DFN,DA=PIIEN,IENS=$$IENS^DILF(.DA)
K DA
I $G(PHIEN)'="" S DA=PHIEN,SIENS=$$IENS^DILF(.DA)
;
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 $G(IENS)="",$G(SIENS)="" S VALUE="" Q
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(FILE,IENS,FLD,"E") Q
.. S VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I")_$C(28)_$$GET1^DIQ(SECFILE,SIENS,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 $G(IENS)="",$G(SIENS)="" S VALUE="" Q
.. I FLD'="" D Q
... S VAL1=$$GET1^DIQ(FILE,IENS,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,SIENS,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=$G(PIIEN) Q
.. I SECFLD'="",SECFLD=.001 S VALUE=$G(PHIEN) Q
.. I $G(IENS)="",$G(SIENS)="" S VALUE="" Q
.. I FLD'="",RET="I" D Q
... S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I") Q
... S VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I")
.. I $G(IENS)="",$G(SIENS)="" S VALUE="" Q
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E") Q
.. S VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"E")
. I TYPE="D" D
.. I DEXEC'="" X DEXEC Q
.. I $G(IENS)="",$G(SIENS)="" S VALUE="" Q
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE) Q
.. S VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE)
. I TYPE="W" D
.. NEW FL,FD
.. K ARRAY S VALUE=""
.. I DEXEC'="" X DEXEC
.. I $G(IENS)="",$G(SIENS)="" S VALUE="" Q
.. I DEXEC="" D
... I FLD'="" D GETS^DIQ(FILE,IENS,FLD,"E","ARRAY") Q
... D GETS^DIQ(SECFILE,SIENS,SECFLD,"E","ARRAY")
.. S FL=$O(ARRAY("")) I FL="" Q
.. S FD=$O(ARRAY(FL,IENS,"")) I FD="" Q ;** look at this one **
.. S AN=0,TXT=ARRAY(FL,IENS,FD,"E") I TXT="" Q
.. K @TXT@("E")
.. F S AN=$O(@TXT@(AN)) Q:AN="" S VALUE=VALUE_@TXT@(AN)_$C(10)
. I HDR["AGGPINUM" S AGGPINUM=VALUE
. I HDR["AGGPIMBN" S AGGPIMBN=VALUE,AGGPEC=$L(HEADR,"^")
. I CODE="AGGPINUM",$G(AGGPIMBN)="" S $P(HDATA,U,AGGPEC)=AGGPINUM
. 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)
K AGGIINS,I,INS,IDATA,ST,STATUS,TYP
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
;
INS(AGGIINS,PEC) ;EP
NEW CTY,ST,ZIP
I $G(AGGIINS)="" Q ""
D GET^AGGINSUR(.IDATA,AGGIINS)
I $G(PEC)="" D
. S CTY=$P($G(@IDATA@(1)),U,4),ST=$P($G(@IDATA@(1)),U,5),ZIP=$P($G(@IDATA@(1)),U,6)
. S VALUE=CTY_", "_ST_" "_ZIP
I $G(PEC)'="" S VALUE=$P($G(@IDATA@(1)),U,PEC)
K @IDATA
Q VALUE
AGGPTPVT ;VNGT/HS/ALA-Private Insurance ; 15 Jul 2010 3:33 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
BLD(DATA,DFN,PIIEN,IINS) ; EP -- AGG BUILD PRIVATE INS
+1 ; Input Parameters
+2 ; DFN - Patient IEN
+3 ; PIIEN - Record IEN
+4 ; IINS - Insurer IEN
+5 ;
+6 NEW UID,II,AGIEN,AGCN,AGDATA,FLD,TYPE,CODE,DEXEC,ARRAY,AN,DQTY,VAL,VALUE,HEADR,HDATA,FILE,FL,FD
+7 NEW VHD,J,K,LEN,LG,LN,ECHR,HDR,SECFILE,SECFLD,RET,VAL1,VAL2,IENS,SIENS,PHIEN,DEF,AGGPEC,AGGPINUM
+8 NEW AGGPIMBN
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("AGGWDISP",UID))
+11 KILL @DATA
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWDISP D UNWIND^%ZTER"
+14 ;
+15 SET DEF="Insurance Edit"
+16 SET AGIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
+17 IF AGIEN=0
SET BMXSEC="RPC Failed: Passed in window name "_DEF_" not found"
QUIT
+18 ;
+19 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,14)
+20 ;
+21 IF $GET(PIIEN)'=""
SET PHIEN=$PIECE($GET(^AUPNPRVT(DFN,11,PIIEN,0)),U,8)
+22 IF $GET(IINS)'=""
SET AGGIINS=IINS
+23 IF $GET(IINS)=""
SET AGGIINS=$PIECE($GET(^AUPNPRVT(DFN,11,PIIEN,0)),U,1)
+24 ;
+25 NEW DA,IENS
+26 IF $GET(PIIEN)'=""
SET DA(1)=DFN
SET DA=PIIEN
SET IENS=$$IENS^DILF(.DA)
+27 KILL DA
+28 IF $GET(PHIEN)'=""
SET DA=PHIEN
SET SIENS=$$IENS^DILF(.DA)
+29 ;
+30 SET HEADR=""
SET HDATA=""
+31 SET AGCN=0
+32 FOR
SET AGCN=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN))
IF 'AGCN
QUIT
Begin DoDot:1
+33 IF $PIECE(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'=""
QUIT
+34 SET AGDATA=$GET(^AGG(9009068.3,AGIEN,10,AGCN,0))
+35 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)
+36 SET RET=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,2)
+37 SET TYPE=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
+38 SET CODE=$PIECE(AGDATA,U,7)
SET HDR=$PIECE(AGDATA,U,2)
+39 SET DEXEC=$GET(^AGG(9009068.3,AGIEN,10,AGCN,8))
+40 IF TYPE="M"
SET VALUE=""
+41 ;
+42 IF TYPE="T"
Begin DoDot:2
+43 IF DEXEC'=""
Begin DoDot:3
+44 SET VAL=""
+45 IF DEXEC'["DQTY"
XECUTE DEXEC
QUIT
+46 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+47 SET DQTY="E"
XECUTE DEXEC
SET VALUE=VAL_VALUE
End DoDot:3
QUIT
+48 IF $GET(IENS)=""
IF $GET(SIENS)=""
SET VALUE=""
QUIT
+49 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$CHAR(28)_$$GET1^DIQ(FILE,IENS,FLD,"E")
QUIT
+50 SET VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I")_$CHAR(28)_$$GET1^DIQ(SECFILE,SIENS,SECFLD,"E")
End DoDot:2
+51 IF (TYPE="C")!(TYPE="K")
Begin DoDot:2
+52 IF DEXEC'=""
Begin DoDot:3
+53 SET VAL=""
+54 IF DEXEC'["DQTY"
XECUTE DEXEC
QUIT
+55 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+56 SET DQTY="E"
XECUTE DEXEC
SET VALUE=VAL_VALUE
End DoDot:3
QUIT
+57 IF $GET(IENS)=""
IF $GET(SIENS)=""
SET VALUE=""
QUIT
+58 IF FLD'=""
Begin DoDot:3
+59 SET VAL1=$$GET1^DIQ(FILE,IENS,FLD,"I")
IF VAL1=""
QUIT
+60 SET VAL2=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,""))
IF VAL2=""
QUIT
+61 SET VAL2=$PIECE(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
+62 SET VALUE=VAL1_$CHAR(28)_VAL2
End DoDot:3
QUIT
+63 SET VAL1=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I")
IF VAL1=""
QUIT
+64 SET VAL2=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN,5,"C",VAL1,""))
IF VAL2=""
QUIT
+65 SET VAL2=$PIECE(^AGG(9009068.3,AGIEN,10,AGCN,5,VAL2,0),U,1)
+66 SET VALUE=VAL1_$CHAR(28)_VAL2
End DoDot:2
+67 IF TYPE="X"!(TYPE="N")
Begin DoDot:2
+68 NEW TYPE
+69 IF DEXEC'=""
XECUTE DEXEC
QUIT
+70 IF FLD'=""
IF FLD=.001
SET VALUE=$GET(PIIEN)
QUIT
+71 IF SECFLD'=""
IF SECFLD=.001
SET VALUE=$GET(PHIEN)
QUIT
+72 IF $GET(IENS)=""
IF $GET(SIENS)=""
SET VALUE=""
QUIT
+73 IF FLD'=""
IF RET="I"
Begin DoDot:3
+74 SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")
QUIT
+75 SET VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I")
End DoDot:3
QUIT
+76 IF $GET(IENS)=""
IF $GET(SIENS)=""
SET VALUE=""
QUIT
+77 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E")
QUIT
+78 SET VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"E")
End DoDot:2
+79 IF TYPE="D"
Begin DoDot:2
+80 IF DEXEC'=""
XECUTE DEXEC
QUIT
+81 IF $GET(IENS)=""
IF $GET(SIENS)=""
SET VALUE=""
QUIT
+82 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
QUIT
+83 SET VALUE=$$GET1^DIQ(SECFILE,SIENS,SECFLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
End DoDot:2
+84 IF TYPE="W"
Begin DoDot:2
+85 NEW FL,FD
+86 KILL ARRAY
SET VALUE=""
+87 IF DEXEC'=""
XECUTE DEXEC
+88 IF $GET(IENS)=""
IF $GET(SIENS)=""
SET VALUE=""
QUIT
+89 IF DEXEC=""
Begin DoDot:3
+90 IF FLD'=""
DO GETS^DIQ(FILE,IENS,FLD,"E","ARRAY")
QUIT
+91 DO GETS^DIQ(SECFILE,SIENS,SECFLD,"E","ARRAY")
End DoDot:3
+92 SET FL=$ORDER(ARRAY(""))
IF FL=""
QUIT
+93 ;** look at this one **
SET FD=$ORDER(ARRAY(FL,IENS,""))
IF FD=""
QUIT
+94 SET AN=0
SET TXT=ARRAY(FL,IENS,FD,"E")
IF TXT=""
QUIT
+95 KILL @TXT@("E")
+96 FOR
SET AN=$ORDER(@TXT@(AN))
IF AN=""
QUIT
SET VALUE=VALUE_@TXT@(AN)_$CHAR(10)
End DoDot:2
+97 IF HDR["AGGPINUM"
SET AGGPINUM=VALUE
+98 IF HDR["AGGPIMBN"
SET AGGPIMBN=VALUE
SET AGGPEC=$LENGTH(HEADR,"^")
+99 IF CODE="AGGPINUM"
IF $GET(AGGPIMBN)=""
SET $PIECE(HDATA,U,AGGPEC)=AGGPINUM
+100 SET HEADR=HEADR_HDR_"^"
+101 SET HDATA=HDATA_$GET(VALUE)_"^"
SET VALUE=""
End DoDot:1
+102 SET HEADR=$$TKO^AGGUL1(HEADR,"^")
SET HDATA=$$TKO^AGGUL1(HDATA,"^")
+103 SET @DATA@(II)=HEADR_$CHAR(30)
+104 IF $$STRIP^XLFSTR(HDATA,$CHAR(28)_"^")'=""
SET II=II+1
SET @DATA@(II)=HDATA_$CHAR(30)
+105 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+106 KILL AGGIINS,I,INS,IDATA,ST,STATUS,TYP
+107 QUIT
+108 ;
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 ;
INS(AGGIINS,PEC) ;EP
+1 NEW CTY,ST,ZIP
+2 IF $GET(AGGIINS)=""
QUIT ""
+3 DO GET^AGGINSUR(.IDATA,AGGIINS)
+4 IF $GET(PEC)=""
Begin DoDot:1
+5 SET CTY=$PIECE($GET(@IDATA@(1)),U,4)
SET ST=$PIECE($GET(@IDATA@(1)),U,5)
SET ZIP=$PIECE($GET(@IDATA@(1)),U,6)
+6 SET VALUE=CTY_", "_ST_" "_ZIP
End DoDot:1
+7 IF $GET(PEC)'=""
SET VALUE=$PIECE($GET(@IDATA@(1)),U,PEC)
+8 KILL @IDATA
+9 QUIT VALUE
