- 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
