AGGUPPVT ;VNGT/HS/ALA-Update Private Insurance ; 28 Jun 2010 12:11 PM
;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
;
UPD(DATA,PROC,DFN,AGGPIIEN,AGGPLIEN,PARMS) ; EP - AGG UPDATE PRIVATE INSUR
; Input
; PROC - 'A' to add, 'E' to edit, 'D' to delete
; DFN - Patient IEN
; AGGPIIEN - Insurer IEN
; AGGPLIEN - Policy Holder IEN
; PARMS - Parameters
NEW UID,II,AGIEN,ERROR,DEF,BN,LIST,FILE,SECFILE,BQ,AGGDATA,AGGDATAI,PHDATA
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGUPPVT",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024ERROR^I00010AGGPIIEN^I00010AGGPLHIN"_$C(30)
;
S DEF="Insurance Edit"
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
S AGIEN=$O(^AGG(9009068.3,"B",DEF,""))
I AGIEN="" D Q
. S II=II+1,@DATA@(II)="-1^"_"RPC Call Failed: "_DEF_" Definition does not exist."_$C(30)
. S II=II+1,@DATA@(II)=$C(31)
S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,AGIEN,0),U,14)
;
;if deleting a Private Insurance
I $G(PROC)="D" D G DONE
. S AGGUPD(FILE,IENS,.01)="@"
. D FILE^DIE("","AGGUPD","ERROR")
;if adding a new Private Insurance
I $G(^AUPNPRVT(DFN,0))="" D
. NEW DIC,X,DINUM
. S DIC="^AUPNPRVT(",DLAYGO=9000006,DIC(0)="L",X=DFN,DINUM=X
. K DO,DD D FILE^DICN
;
D PARS
I $G(PROC)="A" D
. NEW DIC,X,Y
. I $G(AGGPIIEN)="" D
.. I $G(^AUPNPRVT(DFN,11,0))="" S ^AUPNPRVT(DFN,11,0)="^9000006.11P^^"
.. S DIC="^AUPNPRVT("_DFN_",11,"
.. S DIC("P")=$P(^DD(9000006,1101,0),U,2),DIC(0)="L",DA(1)=DFN,X=AGGPIINS
.. D FILE^DICN S AGGPIIEN=+Y
. I $G(AGGPLIEN)="" D
.. NEW SCREEN,N,QFL
.. S SCREEN="I $P(^(0),U,3)=AGGPIINS",PHDATA=$NA(^TMP("DILIST",$J))
.. D FIND^DIC(9000003.1,"",".01;.18","PX",AGGPIHLN,"","",SCREEN,"","","ERROR")
.. S N=0,QFL=0
.. F S N=$O(@PHDATA@(N)) Q:'N D Q:QFL
... I $P(@PHDATA@(N,0),U,4)="" S AGGPLIEN=$P(@PHDATA@(N,0),U,1),QFL=1
.. K @PHDATA
.. I AGGPLIEN="" D
... NEW DIC,DLAYGO,X,Y
... S DIC="^AUPN3PPH(",X=AGGPIHLN,DLAYGO=9000003.1,DIC(0)="L"
... K DO,DD D FILE^DICN S AGGPLIEN=+Y
.. NEW DA,IENS
.. S DA(1)=DFN,DA=AGGPIIEN,IENS=$$IENS^DILF(.DA)
.. S AGGDATAI(FILE,IENS,.08)=AGGPLIEN
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. NEW DA,IENS,PDATA,NAME,PFIEN,FIELD,SECFLD,EXEC,PTYP
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1)
. I NAME="AGGPTDFN",@NAME="" Q
. S PFIEN=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
. S SECFLD=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,7)
. S EXEC=$G(^AGG(9009068.3,AGIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="",SECFLD="" Q
. I FIELD=".001"!(SECFLD=".001") Q
. S PTYP=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
. I PTYP="C"!(PTYP="T")!(PTYP="K") D Q
.. I FIELD'="" D
... S DA(1)=DFN,DA=AGGPIIEN,IENS=$$IENS^DILF(.DA)
... S AGGDATAI(FILE,IENS,FIELD)=@NAME
.. I SECFLD'="" D
... S DA=AGGPLIEN,IENS=$$IENS^DILF(.DA)
... S AGGDATAI(SECFILE,IENS,SECFLD)=@NAME
. I FIELD'="" D
.. S DA(1)=DFN,DA=AGGPIIEN,IENS=$$IENS^DILF(.DA)
.. S AGGDATA(FILE,IENS,FIELD)=@NAME
. I SECFLD'="" D
.. S DA=AGGPLIEN,IENS=$$IENS^DILF(.DA)
.. S AGGDATA(SECFILE,IENS,SECFLD)=@NAME
;
I $D(AGGDATA) D FILE^DIE("","AGGDATA","ERROR")
I $D(AGGDATAI) D FILE^DIE("I","AGGDATAI","ERROR")
D UPOL
;
DONE ;
S RESULT=1_U_U_AGGPIIEN_U_AGGPLIEN
I $D(ERROR) S RESULT="-1"_U_$G(ERROR("DIERR",1,"TEXT",1))_U
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;
I $P(RESULT,U,1)=1 D
. S AGGDATAI(9000001,DFN_",",.03)=DT,AGGDATAI(9000001,DFN_",",.12)=DUZ
. D FILE^DIE("","AGGDATAI","ERROR")
. D EDIT^AGGEXPRT(DFN)
;
S NAME=""
F S NAME=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME)) Q:NAME="" K @NAME
K PROC,DFN,AGGPIIEN,AGGPLIEN
Q
;
PARS ;
I $G(PARMS)="" Q
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. S PFIEN=$O(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^AGGUL1(VALUE)
. I PTYP="C"!(PTYP="K") D
.. I VALUE="" Q
.. S CHIEN=$O(^AGG(9009068.3,AGIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^AGG(9009068.3,AGIEN,10,PFIEN,5,CHIEN,0),U,2)
. I PTYP="W" D Q
.. F AGI=1:1 S AGJ=$P(VALUE,$C(10),AGI) Q:AGJ="" D
... S AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
. S @NAME=VALUE
Q
;
UPOL ; EP - Update Policy Members
NEW IN,MBDFN
S MBDFN=""
F S MBDFN=$O(^AUPNPRVT("C",AGGPLIEN,MBDFN)) Q:MBDFN="" D
. S IN=""
. F S IN=$O(^AUPNPRVT("C",AGGPLIEN,MBDFN,IN)) Q:IN="" D
.. I $P(^AUPNPRVT(MBDFN,11,IN,0),U,1)'=AGGPIINS Q
.. NEW DA,IENS
.. S DA(1)=MBDFN,DA=IN,IENS=$$IENS^DILF(.DA)
.. I $$GET1^DIQ(9000006.11,IENS,.05,"E")="SELF" S AGGDATA(9000006.11,IENS,.06)=AGGPHESD,AGGDATA(9000006.11,IENS,.07)=AGGPHEED
.. I $$GET1^DIQ(9000006.11,IENS,.06,"I")="" S AGGDATA(9000006.11,IENS,.06)=AGGPHESD
.. I $$GET1^DIQ(9000006.11,IENS,.07,"I")="" S AGGDATA(9000006.11,IENS,.07)=AGGPHEED
.. I $$GET1^DIQ(9000006.11,IENS,21,"E")="" S AGGDATA(9000006.11,IENS,21)=$$GET1^DIQ(9000003.1,AGGPLIEN_",",.04,"E")
I $D(AGGDATA) D FILE^DIE("","AGGDATA","ERROR")
K AGGPHESD,AGGPHEED
Q
AGGUPPVT ;VNGT/HS/ALA-Update Private Insurance ; 28 Jun 2010 12:11 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
+2 ;
UPD(DATA,PROC,DFN,AGGPIIEN,AGGPLIEN,PARMS) ; EP - AGG UPDATE PRIVATE INSUR
+1 ; Input
+2 ; PROC - 'A' to add, 'E' to edit, 'D' to delete
+3 ; DFN - Patient IEN
+4 ; AGGPIIEN - Insurer IEN
+5 ; AGGPLIEN - Policy Holder IEN
+6 ; PARMS - Parameters
+7 NEW UID,II,AGIEN,ERROR,DEF,BN,LIST,FILE,SECFILE,BQ,AGGDATA,AGGDATAI,PHDATA
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("AGGUPPVT",UID))
+10 KILL @DATA
+11 ;
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
+14 SET @DATA@(II)="I00010RESULT^T01024ERROR^I00010AGGPIIEN^I00010AGGPLHIN"_$CHAR(30)
+15 ;
+16 SET DEF="Insurance Edit"
+17 ;
+18 SET PARMS=$GET(PARMS,"")
+19 IF PARMS=""
Begin DoDot:1
+20 SET LIST=""
SET BN=""
+21 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+22 KILL PARMS
+23 SET PARMS=LIST
+24 KILL LIST
End DoDot:1
+25 ;
+26 SET AGIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
+27 IF AGIEN=""
Begin DoDot:1
+28 SET II=II+1
SET @DATA@(II)="-1^"_"RPC Call Failed: "_DEF_" Definition does not exist."_$CHAR(30)
+29 SET II=II+1
SET @DATA@(II)=$CHAR(31)
End DoDot:1
QUIT
+30 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,14)
+31 ;
+32 ;if deleting a Private Insurance
+33 IF $GET(PROC)="D"
Begin DoDot:1
+34 SET AGGUPD(FILE,IENS,.01)="@"
+35 DO FILE^DIE("","AGGUPD","ERROR")
End DoDot:1
GOTO DONE
+36 ;if adding a new Private Insurance
+37 IF $GET(^AUPNPRVT(DFN,0))=""
Begin DoDot:1
+38 NEW DIC,X,DINUM
+39 SET DIC="^AUPNPRVT("
SET DLAYGO=9000006
SET DIC(0)="L"
SET X=DFN
SET DINUM=X
+40 KILL DO,DD
DO FILE^DICN
End DoDot:1
+41 ;
+42 DO PARS
+43 IF $GET(PROC)="A"
Begin DoDot:1
+44 NEW DIC,X,Y
+45 IF $GET(AGGPIIEN)=""
Begin DoDot:2
+46 IF $GET(^AUPNPRVT(DFN,11,0))=""
SET ^AUPNPRVT(DFN,11,0)="^9000006.11P^^"
+47 SET DIC="^AUPNPRVT("_DFN_",11,"
+48 SET DIC("P")=$PIECE(^DD(9000006,1101,0),U,2)
SET DIC(0)="L"
SET DA(1)=DFN
SET X=AGGPIINS
+49 DO FILE^DICN
SET AGGPIIEN=+Y
End DoDot:2
+50 IF $GET(AGGPLIEN)=""
Begin DoDot:2
+51 NEW SCREEN,N,QFL
+52 SET SCREEN="I $P(^(0),U,3)=AGGPIINS"
SET PHDATA=$NAME(^TMP("DILIST",$JOB))
+53 DO FIND^DIC(9000003.1,"",".01;.18","PX",AGGPIHLN,"","",SCREEN,"","","ERROR")
+54 SET N=0
SET QFL=0
+55 FOR
SET N=$ORDER(@PHDATA@(N))
IF 'N
QUIT
Begin DoDot:3
+56 IF $PIECE(@PHDATA@(N,0),U,4)=""
SET AGGPLIEN=$PIECE(@PHDATA@(N,0),U,1)
SET QFL=1
End DoDot:3
IF QFL
QUIT
+57 KILL @PHDATA
+58 IF AGGPLIEN=""
Begin DoDot:3
+59 NEW DIC,DLAYGO,X,Y
+60 SET DIC="^AUPN3PPH("
SET X=AGGPIHLN
SET DLAYGO=9000003.1
SET DIC(0)="L"
+61 KILL DO,DD
DO FILE^DICN
SET AGGPLIEN=+Y
End DoDot:3
+62 NEW DA,IENS
+63 SET DA(1)=DFN
SET DA=AGGPIIEN
SET IENS=$$IENS^DILF(.DA)
+64 SET AGGDATAI(FILE,IENS,.08)=AGGPLIEN
End DoDot:2
End DoDot:1
+65 ;
+66 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+67 NEW DA,IENS,PDATA,NAME,PFIEN,FIELD,SECFLD,EXEC,PTYP
+68 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+69 SET NAME=$PIECE(PDATA,"=",1)
+70 IF NAME="AGGPTDFN"
IF @NAME=""
QUIT
+71 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+72 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+73 SET FIELD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,1)
+74 SET SECFLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,3)),U,7)
+75 SET EXEC=$GET(^AGG(9009068.3,AGIEN,10,PFIEN,7))
+76 IF EXEC'=""
XECUTE EXEC
QUIT
+77 IF FIELD=""
IF SECFLD=""
QUIT
+78 IF FIELD=".001"!(SECFLD=".001")
QUIT
+79 SET PTYP=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
+80 IF PTYP="C"!(PTYP="T")!(PTYP="K")
Begin DoDot:2
+81 IF FIELD'=""
Begin DoDot:3
+82 SET DA(1)=DFN
SET DA=AGGPIIEN
SET IENS=$$IENS^DILF(.DA)
+83 SET AGGDATAI(FILE,IENS,FIELD)=@NAME
End DoDot:3
+84 IF SECFLD'=""
Begin DoDot:3
+85 SET DA=AGGPLIEN
SET IENS=$$IENS^DILF(.DA)
+86 SET AGGDATAI(SECFILE,IENS,SECFLD)=@NAME
End DoDot:3
End DoDot:2
QUIT
+87 IF FIELD'=""
Begin DoDot:2
+88 SET DA(1)=DFN
SET DA=AGGPIIEN
SET IENS=$$IENS^DILF(.DA)
+89 SET AGGDATA(FILE,IENS,FIELD)=@NAME
End DoDot:2
+90 IF SECFLD'=""
Begin DoDot:2
+91 SET DA=AGGPLIEN
SET IENS=$$IENS^DILF(.DA)
+92 SET AGGDATA(SECFILE,IENS,SECFLD)=@NAME
End DoDot:2
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+93 ;
+94 IF $DATA(AGGDATA)
DO FILE^DIE("","AGGDATA","ERROR")
+95 IF $DATA(AGGDATAI)
DO FILE^DIE("I","AGGDATAI","ERROR")
+96 DO UPOL
+97 ;
DONE ;
+1 SET RESULT=1_U_U_AGGPIIEN_U_AGGPLIEN
+2 IF $DATA(ERROR)
SET RESULT="-1"_U_$GET(ERROR("DIERR",1,"TEXT",1))_U
+3 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 ;
+6 IF $PIECE(RESULT,U,1)=1
Begin DoDot:1
+7 SET AGGDATAI(9000001,DFN_",",.03)=DT
SET AGGDATAI(9000001,DFN_",",.12)=DUZ
+8 DO FILE^DIE("","AGGDATAI","ERROR")
+9 DO EDIT^AGGEXPRT(DFN)
End DoDot:1
+10 ;
+11 SET NAME=""
+12 FOR
SET NAME=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME))
IF NAME=""
QUIT
KILL @NAME
+13 KILL PROC,DFN,AGGPIIEN,AGGPLIEN
+14 QUIT
+15 ;
PARS ;
+1 IF $GET(PARMS)=""
QUIT
+2 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+3 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+4 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+5 SET PFIEN=$ORDER(^AGG(9009068.3,AGIEN,10,"AC",NAME,""))
+6 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+7 SET PTYP=$PIECE($GET(^AGG(9009068.3,AGIEN,10,PFIEN,1)),U,1)
+8 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+9 IF PTYP="C"!(PTYP="K")
Begin DoDot:2
+10 IF VALUE=""
QUIT
+11 SET CHIEN=$ORDER(^AGG(9009068.3,AGIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+12 SET VALUE=$PIECE(^AGG(9009068.3,AGIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+13 IF PTYP="W"
Begin DoDot:2
+14 FOR AGI=1:1
SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
IF AGJ=""
QUIT
Begin DoDot:3
+15 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
End DoDot:3
End DoDot:2
QUIT
+16 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+17 QUIT
+18 ;
UPOL ; EP - Update Policy Members
+1 NEW IN,MBDFN
+2 SET MBDFN=""
+3 FOR
SET MBDFN=$ORDER(^AUPNPRVT("C",AGGPLIEN,MBDFN))
IF MBDFN=""
QUIT
Begin DoDot:1
+4 SET IN=""
+5 FOR
SET IN=$ORDER(^AUPNPRVT("C",AGGPLIEN,MBDFN,IN))
IF IN=""
QUIT
Begin DoDot:2
+6 IF $PIECE(^AUPNPRVT(MBDFN,11,IN,0),U,1)'=AGGPIINS
QUIT
+7 NEW DA,IENS
+8 SET DA(1)=MBDFN
SET DA=IN
SET IENS=$$IENS^DILF(.DA)
+9 IF $$GET1^DIQ(9000006.11,IENS,.05,"E")="SELF"
SET AGGDATA(9000006.11,IENS,.06)=AGGPHESD
SET AGGDATA(9000006.11,IENS,.07)=AGGPHEED
+10 IF $$GET1^DIQ(9000006.11,IENS,.06,"I")=""
SET AGGDATA(9000006.11,IENS,.06)=AGGPHESD
+11 IF $$GET1^DIQ(9000006.11,IENS,.07,"I")=""
SET AGGDATA(9000006.11,IENS,.07)=AGGPHEED
+12 IF $$GET1^DIQ(9000006.11,IENS,21,"E")=""
SET AGGDATA(9000006.11,IENS,21)=$$GET1^DIQ(9000003.1,AGGPLIEN_",",.04,"E")
End DoDot:2
End DoDot:1
+13 IF $DATA(AGGDATA)
DO FILE^DIE("","AGGDATA","ERROR")
+14 KILL AGGPHESD,AGGPHEED
+15 QUIT
