- AGGDCUPD ;VNGT/HS/ALA-Document Update ; 19 May 2010 3:32 PM
- ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
- ;
- ;
- UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE DOCUMENTS
- ; Input
- ; DEF - Definition Name
- ; DFN - Patient IEN
- ; PARMS - Parameters
- NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,WDATA
- NEW AGGDATA,ERROR,RESULT,AGGINT,PTYP,AGGPTRSI,AGGRHIDT,AGGRHIO,AGGRHTXT
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("AGGDCUPD",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"_$C(30)
- ;
- S VFIEN=$O(^AGG(9009068.3,"B",DEF,""))
- I VFIEN="" S BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist." Q
- S FILE=$P(^AGG(9009068.3,VFIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,VFIEN,0),U,14)
- ;
- I $G(^AUPNNPP(DFN,0))="" D NEWP
- ;
- ; Get previous data
- NEW FLD,LIST
- S FLD="",LIST="" F S FLD=$O(^AGG(9009068.3,VFIEN,10,"AD",FLD)) Q:FLD="" S LIST=LIST_FLD_";"
- S LIST=$$TKO^AGGUL1(LIST,";")
- D GETS^DIQ(FILE,DFN_",",LIST,"I","AGGINT")
- ;
- NEW FLD,LIST
- S DA=$O(^AUPNRHI("B",DFN,""))
- I DA'="" D
- . S FLD="",LIST="" F S FLD=$O(^AGG(9009068.3,VFIEN,10,"AG",FLD)) Q:FLD="" S LIST=LIST_FLD_";"
- . D GETS^DIQ(SECFILE,DA_",",LIST,"I","AGGINT")
- ;
- 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
- ;
- 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)
- . ;I VALUE="" S VALUE="@"
- . ;I VALUE="" Q
- . S PFIEN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
- . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
- . S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
- . I PTYP="D" S VALUE=$$DATE^AGGUL1(VALUE)
- . ;I PTYP="T" S VALUE=VALUE
- . I PTYP="C"!(PTYP="K") D
- .. I VALUE="" Q
- .. S CHIEN=$O(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
- .. S VALUE=$P(^AGG(9009068.3,VFIEN,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 FIELD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
- . I FIELD'="",$G(AGGINT(FILE,DFN_",",FIELD,"I"))'="",VALUE="" S VALUE="@"
- . I SECFLD'="",$G(AGGINT(SECFILE,DA_",",SECFLD,"I"))'="",VALUE="" S VALUE="@"
- . S @NAME=VALUE
- ;
- 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)
- . S PFIEN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
- . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
- . S FIELD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
- . S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
- . S EXEC=$G(^AGG(9009068.3,VFIEN,10,PFIEN,7))
- . I EXEC'="" X EXEC Q
- . I FIELD="",SECFLD="" Q
- . S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
- . I PTYP="C"!(PTYP="T")!(PTYP="K") D Q
- .. I FIELD'="" S AGGDATAI(FILE,DFN_",",FIELD)=@NAME Q
- .. I SECFLD'="" S AGGDATAI(SECFILE,DA_",",SECFLD)=@NAME
- . I FIELD'="" S AGGDATA(FILE,DFN_",",FIELD)=@NAME Q
- . I SECFLD'="" S AGGDATA(SECFILE,DA_",",SECFLD)=@NAME
- ;
- S RESULT=1_U
- ;
- I $D(AGGWP) D
- . NEW FL,FD,IENS,FLAG
- . S FL=""
- . F S FL=$O(AGGWP(FL)) Q:FL="" D
- .. S IENS=""
- .. F S IENS=$O(AGGWP(FL,IENS)) Q:IENS="" D
- ... S FD=""
- ... F S FD=$O(AGGWP(FL,IENS,FD)) Q:FD="" D
- .... S FLAG=""
- .... ;I FL=9000001,FD=1301 S FLAG="A"
- .... I $D(WDATA) D WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
- ;
- K AGGWP,AGWP
- I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
- K ERROR
- I $D(AGGDATA)>0 D FILE^DIE("","AGGDATA","ERROR")
- I $D(AGGDATAI)>0 D FILE^DIE("I","AGGDATAI","ERROR")
- I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
- I $P(RESULT,U,1)'=-1 S RESULT=1_U
- S II=II+1,@DATA@(II)=RESULT_$C(30)
- ;
- 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)
- ;
- K AGGDATA,AGGDATAI
- S NAME=""
- F S NAME=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME)) Q:NAME="" K @NAME
- ;
- DONE ;
- S II=II+1,@DATA@(II)=$C(31)
- Q
- ;
- NEWP ;
- NEW DIC,DLAYGO,Y,X,DINUM
- S DIC="^AUPNNPP("
- S DIC(0)="L"
- S DLAYGO=9000038
- ;S X="`"_DFN
- S (X,DINUM)=DFN
- ;D ^DIC
- ;I Y=-1 K DO,DD D FILE^DICN
- K DO,DD D FILE^DICN
- S DA=+Y
- S AGGDATAI(FILE,DA_",",.06)=$$NOW^XLFDT()
- S AGGDATAI(FILE,DA_",",.07)=DUZ
- Q
- ;
- NEWR ;
- NEW DIC,DLAYGO,Y,X
- S DIC="^AUPNRHI("
- S DIC(0)="L"
- S DLAYGO=9000039
- S X=DFN
- D ^DIC
- I Y=-1 K DO,DD D FILE^DICN
- S DA=+Y
- Q
- ;
- RHI ; EP
- I $G(AGGPTRSI)="" Q
- NEW FLD,DA,STAT
- S DA=$O(^AUPNRHI("B",DFN,""))
- I DA="" D NEWR
- S DA=$O(^AUPNRHI("B",DFN,""))
- S STAT=AGGPTRSI
- S AGGDATA(9000039,DA_",",.03)=AGGPTRSI
- S FLD=$S(STAT="P":.11,STAT="A":.21,STAT="R":.41,STAT="N":.31,1:"")
- I $G(AGGRHIDT)="",FLD'="" S AGGDATAI(9000039,DA_",",FLD)=$$DT^XLFDT()
- I $G(AGGRHIDT)'="",FLD'="" S AGGDATAI(9000039,DA_",",FLD)=AGGRHIDT
- S FLD=$S(STAT="A":.22,STAT="R":.42,STAT="N":.32,1:"")
- I $G(AGGRHIO)'="",FLD'="" S AGGDATA(9000039,DA_",",FLD)=AGGRHIO
- I $G(AGGRHTXT)'="" S AGGDATA(9000039,DA_",",.02)=AGGRHTXT
- S FLD=$S(STAT="P":.12,STAT="A":.23,STAT="R":.43,STAT="N":.33,STAT="E":.51,1:"")
- I FLD'="" S AGGDATAI(9000039,DA_",",FLD)=DUZ
- S FLD=$S(STAT="E":.52,STAT="P":.13,STAT="A":.24,STAT="R":.44,STAT="N":.34,1:"")
- I FLD'="" S AGGDATAI(9000039,DA_",",FLD)=$$NOW^XLFDT()
- Q
- ;
- MRECU(DFN,AGGPTMRS) ; EP
- I $G(AGGPTMRS)="" Q
- I $G(DFN)="" Q
- I $G(^AUPNPAT(DFN,41,DUZ(2),0))="" Q
- NEW DA,IENS
- S DA(1)=DFN,DA=DUZ(2),IENS=$$IENS^DILF(.DA)
- S AGGDATAI(9000001.41,IENS,.04)=$G(AGGPTMRS)
- Q
- AGGDCUPD ;VNGT/HS/ALA-Document Update ; 19 May 2010 3:32 PM
- +1 ;;1.0;PATIENT REGISTRATION GUI;**1**;Nov 15, 2010
- +2 ;
- +3 ;
- UPD(DATA,DEF,DFN,PARMS) ; EP - AGG UPDATE DOCUMENTS
- +1 ; Input
- +2 ; DEF - Definition Name
- +3 ; DFN - Patient IEN
- +4 ; PARMS - Parameters
- +5 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC,WDATA
- +6 NEW AGGDATA,ERROR,RESULT,AGGINT,PTYP,AGGPTRSI,AGGRHIDT,AGGRHIO,AGGRHTXT
- +7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +8 SET DATA=$NAME(^TMP("AGGDCUPD",UID))
- +9 KILL @DATA
- +10 ;
- +11 SET II=0
- +12 ; SAC 2006 2.2.3.3.2
- NEW $ESTACK,$ETRAP
- SET $ETRAP="D ERR^AGGPTUPD D UNWIND^%ZTER"
- +13 SET @DATA@(II)="I00010RESULT^T01024ERROR"_$CHAR(30)
- +14 ;
- +15 SET VFIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
- +16 IF VFIEN=""
- SET BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist."
- QUIT
- +17 SET FILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,2)
- SET SECFILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,14)
- +18 ;
- +19 IF $GET(^AUPNNPP(DFN,0))=""
- DO NEWP
- +20 ;
- +21 ; Get previous data
- +22 NEW FLD,LIST
- +23 SET FLD=""
- SET LIST=""
- FOR
- SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AD",FLD))
- IF FLD=""
- QUIT
- SET LIST=LIST_FLD_";"
- +24 SET LIST=$$TKO^AGGUL1(LIST,";")
- +25 DO GETS^DIQ(FILE,DFN_",",LIST,"I","AGGINT")
- +26 ;
- +27 NEW FLD,LIST
- +28 SET DA=$ORDER(^AUPNRHI("B",DFN,""))
- +29 IF DA'=""
- Begin DoDot:1
- +30 SET FLD=""
- SET LIST=""
- FOR
- SET FLD=$ORDER(^AGG(9009068.3,VFIEN,10,"AG",FLD))
- IF FLD=""
- QUIT
- SET LIST=LIST_FLD_";"
- +31 DO GETS^DIQ(SECFILE,DA_",",LIST,"I","AGGINT")
- End DoDot:1
- +32 ;
- +33 SET PARMS=$GET(PARMS,"")
- +34 IF PARMS=""
- Begin DoDot:1
- +35 SET LIST=""
- SET BN=""
- +36 FOR
- SET BN=$ORDER(PARMS(BN))
- IF BN=""
- QUIT
- SET LIST=LIST_PARMS(BN)
- +37 KILL PARMS
- +38 SET PARMS=LIST
- +39 KILL LIST
- End DoDot:1
- +40 ;
- +41 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
- Begin DoDot:1
- +42 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
- IF PDATA=""
- QUIT
- +43 SET NAME=$PIECE(PDATA,"=",1)
- SET VALUE=$PIECE(PDATA,"=",2,99)
- +44 ;I VALUE="" S VALUE="@"
- +45 ;I VALUE="" Q
- +46 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
- +47 IF PFIEN=""
- SET BMXSEC=NAME_" not a valid parameter for this update"
- QUIT
- +48 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
- +49 IF PTYP="D"
- SET VALUE=$$DATE^AGGUL1(VALUE)
- +50 ;I PTYP="T" S VALUE=VALUE
- +51 IF PTYP="C"!(PTYP="K")
- Begin DoDot:2
- +52 IF VALUE=""
- QUIT
- +53 SET CHIEN=$ORDER(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
- IF CHIEN=""
- QUIT
- +54 SET VALUE=$PIECE(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
- End DoDot:2
- +55 IF PTYP="W"
- Begin DoDot:2
- +56 FOR AGI=1:1
- SET AGJ=$PIECE(VALUE,$CHAR(10),AGI)
- IF AGJ=""
- QUIT
- Begin DoDot:3
- +57 SET AGWP(AGI,0)=$$CTRL^AGGUL1(AGJ)
- End DoDot:3
- End DoDot:2
- QUIT
- +58 ;
- +59 SET FIELD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1)
- SET SECFLD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
- +60 IF FIELD'=""
- IF $GET(AGGINT(FILE,DFN_",",FIELD,"I"))'=""
- IF VALUE=""
- SET VALUE="@"
- +61 IF SECFLD'=""
- IF $GET(AGGINT(SECFILE,DA_",",SECFLD,"I"))'=""
- IF VALUE=""
- SET VALUE="@"
- +62 SET @NAME=VALUE
- End DoDot:1
- IF $GET(BMXSEC)'=""
- QUIT
- +63 ;
- +64 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
- Begin DoDot:1
- +65 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
- IF PDATA=""
- QUIT
- +66 SET NAME=$PIECE(PDATA,"=",1)
- +67 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
- +68 IF PFIEN=""
- SET BMXSEC=NAME_" not a valid parameter for this update"
- QUIT
- +69 SET FIELD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,1)
- SET SECFLD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,3)),U,7)
- +70 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
- +71 SET EXEC=$GET(^AGG(9009068.3,VFIEN,10,PFIEN,7))
- +72 IF EXEC'=""
- XECUTE EXEC
- QUIT
- +73 IF FIELD=""
- IF SECFLD=""
- QUIT
- +74 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
- +75 IF PTYP="C"!(PTYP="T")!(PTYP="K")
- Begin DoDot:2
- +76 IF FIELD'=""
- SET AGGDATAI(FILE,DFN_",",FIELD)=@NAME
- QUIT
- +77 IF SECFLD'=""
- SET AGGDATAI(SECFILE,DA_",",SECFLD)=@NAME
- End DoDot:2
- QUIT
- +78 IF FIELD'=""
- SET AGGDATA(FILE,DFN_",",FIELD)=@NAME
- QUIT
- +79 IF SECFLD'=""
- SET AGGDATA(SECFILE,DA_",",SECFLD)=@NAME
- End DoDot:1
- IF $GET(BMXSEC)'=""
- QUIT
- +80 ;
- +81 SET RESULT=1_U
- +82 ;
- +83 IF $DATA(AGGWP)
- Begin DoDot:1
- +84 NEW FL,FD,IENS,FLAG
- +85 SET FL=""
- +86 FOR
- SET FL=$ORDER(AGGWP(FL))
- IF FL=""
- QUIT
- Begin DoDot:2
- +87 SET IENS=""
- +88 FOR
- SET IENS=$ORDER(AGGWP(FL,IENS))
- IF IENS=""
- QUIT
- Begin DoDot:3
- +89 SET FD=""
- +90 FOR
- SET FD=$ORDER(AGGWP(FL,IENS,FD))
- IF FD=""
- QUIT
- Begin DoDot:4
- +91 SET FLAG=""
- +92 ;I FL=9000001,FD=1301 S FLAG="A"
- +93 IF $DATA(WDATA)
- DO WP^DIE(FL,IENS,FD,FLAG,WDATA,"ERROR")
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +94 ;
- +95 KILL AGGWP,AGWP
- +96 IF $DATA(ERROR)>0
- SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
- +97 KILL ERROR
- +98 IF $DATA(AGGDATA)>0
- DO FILE^DIE("","AGGDATA","ERROR")
- +99 IF $DATA(AGGDATAI)>0
- DO FILE^DIE("I","AGGDATAI","ERROR")
- +100 IF $DATA(ERROR)>0
- SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
- +101 IF $PIECE(RESULT,U,1)'=-1
- SET RESULT=1_U
- +102 SET II=II+1
- SET @DATA@(II)=RESULT_$CHAR(30)
- +103 ;
- +104 IF $PIECE(RESULT,U,1)=1
- Begin DoDot:1
- +105 SET AGGDATAI(9000001,DFN_",",.03)=DT
- SET AGGDATAI(9000001,DFN_",",.12)=DUZ
- +106 DO FILE^DIE("","AGGDATAI","ERROR")
- +107 DO EDIT^AGGEXPRT(DFN)
- End DoDot:1
- +108 ;
- +109 KILL AGGDATA,AGGDATAI
- +110 SET NAME=""
- +111 FOR
- SET NAME=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME))
- IF NAME=""
- QUIT
- KILL @NAME
- +112 ;
- DONE ;
- +1 SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +2 QUIT
- +3 ;
- NEWP ;
- +1 NEW DIC,DLAYGO,Y,X,DINUM
- +2 SET DIC="^AUPNNPP("
- +3 SET DIC(0)="L"
- +4 SET DLAYGO=9000038
- +5 ;S X="`"_DFN
- +6 SET (X,DINUM)=DFN
- +7 ;D ^DIC
- +8 ;I Y=-1 K DO,DD D FILE^DICN
- +9 KILL DO,DD
- DO FILE^DICN
- +10 SET DA=+Y
- +11 SET AGGDATAI(FILE,DA_",",.06)=$$NOW^XLFDT()
- +12 SET AGGDATAI(FILE,DA_",",.07)=DUZ
- +13 QUIT
- +14 ;
- NEWR ;
- +1 NEW DIC,DLAYGO,Y,X
- +2 SET DIC="^AUPNRHI("
- +3 SET DIC(0)="L"
- +4 SET DLAYGO=9000039
- +5 SET X=DFN
- +6 DO ^DIC
- +7 IF Y=-1
- KILL DO,DD
- DO FILE^DICN
- +8 SET DA=+Y
- +9 QUIT
- +10 ;
- RHI ; EP
- +1 IF $GET(AGGPTRSI)=""
- QUIT
- +2 NEW FLD,DA,STAT
- +3 SET DA=$ORDER(^AUPNRHI("B",DFN,""))
- +4 IF DA=""
- DO NEWR
- +5 SET DA=$ORDER(^AUPNRHI("B",DFN,""))
- +6 SET STAT=AGGPTRSI
- +7 SET AGGDATA(9000039,DA_",",.03)=AGGPTRSI
- +8 SET FLD=$SELECT(STAT="P":.11,STAT="A":.21,STAT="R":.41,STAT="N":.31,1:"")
- +9 IF $GET(AGGRHIDT)=""
- IF FLD'=""
- SET AGGDATAI(9000039,DA_",",FLD)=$$DT^XLFDT()
- +10 IF $GET(AGGRHIDT)'=""
- IF FLD'=""
- SET AGGDATAI(9000039,DA_",",FLD)=AGGRHIDT
- +11 SET FLD=$SELECT(STAT="A":.22,STAT="R":.42,STAT="N":.32,1:"")
- +12 IF $GET(AGGRHIO)'=""
- IF FLD'=""
- SET AGGDATA(9000039,DA_",",FLD)=AGGRHIO
- +13 IF $GET(AGGRHTXT)'=""
- SET AGGDATA(9000039,DA_",",.02)=AGGRHTXT
- +14 SET FLD=$SELECT(STAT="P":.12,STAT="A":.23,STAT="R":.43,STAT="N":.33,STAT="E":.51,1:"")
- +15 IF FLD'=""
- SET AGGDATAI(9000039,DA_",",FLD)=DUZ
- +16 SET FLD=$SELECT(STAT="E":.52,STAT="P":.13,STAT="A":.24,STAT="R":.44,STAT="N":.34,1:"")
- +17 IF FLD'=""
- SET AGGDATAI(9000039,DA_",",FLD)=$$NOW^XLFDT()
- +18 QUIT
- +19 ;
- MRECU(DFN,AGGPTMRS) ; EP
- +1 IF $GET(AGGPTMRS)=""
- QUIT
- +2 IF $GET(DFN)=""
- QUIT
- +3 IF $GET(^AUPNPAT(DFN,41,DUZ(2),0))=""
- QUIT
- +4 NEW DA,IENS
- +5 SET DA(1)=DFN
- SET DA=DUZ(2)
- SET IENS=$$IENS^DILF(.DA)
- +6 SET AGGDATAI(9000001.41,IENS,.04)=$GET(AGGPTMRS)
- +7 QUIT