AGTX2 ; IHS/ASDS/EFG - EXPORT REG DATA CONT'D ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
R2P1 ;EP -
S AGTEMP(2)="RG2",AGTEMP(5)="RG5",(AGNAME,AGLN,AGMN,AGFN)=""
I $D(^DPT(AGRCT,.24)) S AGNAME=$P(^(.24),U,3) D NAMECVT^AGTX1 S $P(AGTEMP(2),U,2)=AGLN,$P(AGTEMP(2),U,3)=AGFN,$P(AGTEMP(2),U,4)=$E(AGMN,1,1)
I $D(^DPT(AGRCT,.35)) S AGVAL=^(.35) D D8CV^AGTX1:AGVAL]"" S $P(AGTEMP(2),U,5)=AGVAL
K AGFLG
S AGCT=""
G MCR:'$D(^AUPNRRE(AGRCT,0)),MCR:$P(^AUPNRRE(AGRCT,0),U,3)=""!($P(^(0),U,4)="")
S AGNUMB=$P(^AUTTRRP($P(^AUPNRRE(AGRCT,0),U,3),0),U)_$P(^AUPNRRE(AGRCT,0),U,4),AGRR=0
RRD ;
S AGRR=$O(^AUPNRRE(AGRCT,11,AGRR))
G MCR:AGRR=""
S AGR1=AGRR,AGCT=$P(^AUPNRRE(AGRCT,11,AGR1,0),U,3),AGVAL=$P(^(0),U),AGELGEND=$P(^(0),U,2)
D PTA
S:$P(^AUPNRRE(AGRCT,11,AGR1,0),U,2)]"" $P(AGTEMP(2),U,AGN1)="N"
G RRD
MCR ;
G MCD:'$D(^AUPNMCR(AGRCT,0)),MCD:$P(^AUPNMCR(AGRCT,0),U,3)=""!($P(^(0),U,4)="")
S AGNUMB=$P(^AUPNMCR(AGRCT,0),U,3)_$P(^AUTTMCS($P(^AUPNMCR(AGRCT,0),U,4),0),U),AGRR=0
G:'$D(^AUPNMCR(AGRCT,21)) MCRCONT
I $P(^AUPNMCR(AGRCT,21),U)]"" S AGNAME=$P(^(21),U) D NAMECVT^AGTX1 S $P(AGTEMP(5),U,7)=AGLN,$P(AGTEMP(5),U,8)=AGFN,$P(AGTEMP(5),U,9)=AGMN
I $P(^AUPNMCR(AGRCT,21),U,2)]"" S AGVAL=$P(^(21),U,2) D D8CV^AGTX1 S $P(AGTEMP(5),U,13)=AGVAL
MCRCONT ;
S AGRR=$O(^AUPNMCR(AGRCT,11,AGRR))
G MCD:AGRR=""!('AGRR)
S AGR1=AGRR,AGCT=$P(^AUPNMCR(AGRCT,11,AGR1,0),U,3),AGVAL=$P(^(0),U),AGELGEND=$P(^(0),U,2)
D PTA
S:$P(^AUPNMCR(AGRCT,11,AGR1,0),U,2)]"" $P(AGTEMP(2),U,AGN1)="N"
G MCRCONT
MCD ;
S AGCT="MM"
G PRVINS:'$D(^AUPNMCD("AB",AGRCT))
S DA=AGRCT,AG("DRENT")=0,DIC=9000001.51,DR=.03 D ^AGDICLK G PRVINS:$D(AG("LKERR"))!($G(AG("LKDATA"))="") G:'$D(^AUTTCOM(AG("LKDATA"),0)) PRVINS
S AG("STATE")=$P(^AUTTCOM(AG("LKDATA"),0),U,3),(AG("NM"),AG("DT"))=0,AGELGEND=""
MCD2 ;
S AG("NM")=$O(^AUPNMCD("AB",AGRCT,AG("STATE"),AG("NM")))
G MCD4:AG("NM")=""
S DA=0
MCD3 ;
S DA=$O(^AUPNMCD("AB",AGRCT,AG("STATE"),AG("NM"),DA))
G MCD2:DA=""
S AG("DRENT")=0,DIC=9000004.11,DR=.01
D ^AGDICLK
G MCD3:$D(AG("LKERR"))
I AG("LKDATA")>AG("DT") S AG("DT")=AG("LKDATA")_U_DA,AGELGEND=$P(@AGL,U,2),AG("MCDCT")=$P(@AGL,U,3),AG("MCDST")=$P(@AGL(1),U,4)
G MCD3
MCD4 ;
G PRVINS:+AG("DT")=0
S DA=$P(AG("DT"),U,2),AG=$P(^AUPNMCD(DA,0),U,3),AGNUMB=$E(AG,1,14),AGVAL=+AG("DT")
D PTA
S $P(AGTEMP(2),U,32)=$P(^DIC(5,AG("MCDST"),0),U,3)
S $P(AGTEMP(2),U,33)=AG("MCDCT")
G:'$D(^AUPNMCD(DA,21)) PRVINS
I $P(^AUPNMCD(DA,21),U)]"" S AGNAME=$P(^(21),U) D NAMECVT^AGTX1 S $P(AGTEMP(5),U,10)=AGLN,$P(AGTEMP(5),U,11)=AGFN,$P(AGTEMP(5),U,12)=AGMN
I $P(^AUPNMCD(DA,21),U,2)]"" S AGVAL=$P(^(21),U,2) D D8CV^AGTX1 S $P(AGTEMP(5),U,14)=AGVAL
PRVINS ;
S:$D(^AUPNPRVT(AGRCT,0)) $P(AGTEMP(2),U,24)="Y"
S $P(AGTEMP(2),U,22)=$P($G(^DPT(DFN,"VET")),U,1)
CHSELG ;
S AGMEDDT=$P(^AUPNPAT(AGRCT,0),U,4)
I $G(AGMEDDT) S AGMEDDT=AGMEDDT+17000000
S:$P($G(^AUPNPAT(AGRCT,11)),U,12)="C" $P(AGTEMP(2),U,25)="Y" S $P(AGTEMP(2),U,27)=AG("MODCODE"),$P(AGTEMP(2),U,28)=AGMEDDT
K AGMEDDT
S:$D(^AUPNPAT(AGRCT,11)) $P(AGTEMP(2),U,29)=$P(^(11),U,12) I $P(^AUPNPAT(AGRCT,0),U,2) S $P(AGTEMP(2),U,30)=$P(^(0),U,2)+17000000
G ^AGTX3 ;>GOTO PROC HRNS
PTA ;
Q:'$D(AGCT)
Q:(AGCT'?1A.A)
Q:$D(AGFLG(AGCT))
S AGN1=$S(AGCT="A":6,AGCT="B":10,AGCT="AB":14,AGCT="MM":18,1:0)
Q:AGN1=0
S $P(AGTEMP(2),U,AGN1)="Y",$P(AGTEMP(2),U,AGN1+1)=AGNUMB,$P(AGTEMP(2),U,AGN1+2)=""
D D8CV^AGTX1 S $P(AGTEMP(2),U,AGN1+3)=AGVAL
I $G(AGELGEND) S AGELGEND=AGELGEND+17000000
S $P(AGTEMP(5),U,$S(AGCT="A":15,AGCT="B":16,AGCT="AB":17,AGCT="MM":18))=AGELGEND
S AGFLG(AGCT)=""
Q
AGTX2 ; IHS/ASDS/EFG - EXPORT REG DATA CONT'D ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
R2P1 ;EP -
+1 SET AGTEMP(2)="RG2"
SET AGTEMP(5)="RG5"
SET (AGNAME,AGLN,AGMN,AGFN)=""
+2 IF $DATA(^DPT(AGRCT,.24))
SET AGNAME=$PIECE(^(.24),U,3)
DO NAMECVT^AGTX1
SET $PIECE(AGTEMP(2),U,2)=AGLN
SET $PIECE(AGTEMP(2),U,3)=AGFN
SET $PIECE(AGTEMP(2),U,4)=$EXTRACT(AGMN,1,1)
+3 IF $DATA(^DPT(AGRCT,.35))
SET AGVAL=^(.35)
IF AGVAL]""
DO D8CV^AGTX1
SET $PIECE(AGTEMP(2),U,5)=AGVAL
+4 KILL AGFLG
+5 SET AGCT=""
+6 IF '$DATA(^AUPNRRE(AGRCT,0))
GOTO MCR
IF $PIECE(^AUPNRRE(AGRCT,0),U,3)=""!($PIECE(^(0),U,4)="")
GOTO MCR
+7 SET AGNUMB=$PIECE(^AUTTRRP($PIECE(^AUPNRRE(AGRCT,0),U,3),0),U)_$PIECE(^AUPNRRE(AGRCT,0),U,4)
SET AGRR=0
RRD ;
+1 SET AGRR=$ORDER(^AUPNRRE(AGRCT,11,AGRR))
+2 IF AGRR=""
GOTO MCR
+3 SET AGR1=AGRR
SET AGCT=$PIECE(^AUPNRRE(AGRCT,11,AGR1,0),U,3)
SET AGVAL=$PIECE(^(0),U)
SET AGELGEND=$PIECE(^(0),U,2)
+4 DO PTA
+5 IF $PIECE(^AUPNRRE(AGRCT,11,AGR1,0),U,2)]""
SET $PIECE(AGTEMP(2),U,AGN1)="N"
+6 GOTO RRD
MCR ;
+1 IF '$DATA(^AUPNMCR(AGRCT,0))
GOTO MCD
IF $PIECE(^AUPNMCR(AGRCT,0),U,3)=""!($PIECE(^(0),U,4)="")
GOTO MCD
+2 SET AGNUMB=$PIECE(^AUPNMCR(AGRCT,0),U,3)_$PIECE(^AUTTMCS($PIECE(^AUPNMCR(AGRCT,0),U,4),0),U)
SET AGRR=0
+3 IF '$DATA(^AUPNMCR(AGRCT,21))
GOTO MCRCONT
+4 IF $PIECE(^AUPNMCR(AGRCT,21),U)]""
SET AGNAME=$PIECE(^(21),U)
DO NAMECVT^AGTX1
SET $PIECE(AGTEMP(5),U,7)=AGLN
SET $PIECE(AGTEMP(5),U,8)=AGFN
SET $PIECE(AGTEMP(5),U,9)=AGMN
+5 IF $PIECE(^AUPNMCR(AGRCT,21),U,2)]""
SET AGVAL=$PIECE(^(21),U,2)
DO D8CV^AGTX1
SET $PIECE(AGTEMP(5),U,13)=AGVAL
MCRCONT ;
+1 SET AGRR=$ORDER(^AUPNMCR(AGRCT,11,AGRR))
+2 IF AGRR=""!('AGRR)
GOTO MCD
+3 SET AGR1=AGRR
SET AGCT=$PIECE(^AUPNMCR(AGRCT,11,AGR1,0),U,3)
SET AGVAL=$PIECE(^(0),U)
SET AGELGEND=$PIECE(^(0),U,2)
+4 DO PTA
+5 IF $PIECE(^AUPNMCR(AGRCT,11,AGR1,0),U,2)]""
SET $PIECE(AGTEMP(2),U,AGN1)="N"
+6 GOTO MCRCONT
MCD ;
+1 SET AGCT="MM"
+2 IF '$DATA(^AUPNMCD("AB",AGRCT))
GOTO PRVINS
+3 SET DA=AGRCT
SET AG("DRENT")=0
SET DIC=9000001.51
SET DR=.03
DO ^AGDICLK
IF $DATA(AG("LKERR"))!($GET(AG("LKDATA"))="")
GOTO PRVINS
IF '$DATA(^AUTTCOM(AG("LKDATA"),0))
GOTO PRVINS
+4 SET AG("STATE")=$PIECE(^AUTTCOM(AG("LKDATA"),0),U,3)
SET (AG("NM"),AG("DT"))=0
SET AGELGEND=""
MCD2 ;
+1 SET AG("NM")=$ORDER(^AUPNMCD("AB",AGRCT,AG("STATE"),AG("NM")))
+2 IF AG("NM")=""
GOTO MCD4
+3 SET DA=0
MCD3 ;
+1 SET DA=$ORDER(^AUPNMCD("AB",AGRCT,AG("STATE"),AG("NM"),DA))
+2 IF DA=""
GOTO MCD2
+3 SET AG("DRENT")=0
SET DIC=9000004.11
SET DR=.01
+4 DO ^AGDICLK
+5 IF $DATA(AG("LKERR"))
GOTO MCD3
+6 IF AG("LKDATA")>AG("DT")
SET AG("DT")=AG("LKDATA")_U_DA
SET AGELGEND=$PIECE(@AGL,U,2)
SET AG("MCDCT")=$PIECE(@AGL,U,3)
SET AG("MCDST")=$PIECE(@AGL(1),U,4)
+7 GOTO MCD3
MCD4 ;
+1 IF +AG("DT")=0
GOTO PRVINS
+2 SET DA=$PIECE(AG("DT"),U,2)
SET AG=$PIECE(^AUPNMCD(DA,0),U,3)
SET AGNUMB=$EXTRACT(AG,1,14)
SET AGVAL=+AG("DT")
+3 DO PTA
+4 SET $PIECE(AGTEMP(2),U,32)=$PIECE(^DIC(5,AG("MCDST"),0),U,3)
+5 SET $PIECE(AGTEMP(2),U,33)=AG("MCDCT")
+6 IF '$DATA(^AUPNMCD(DA,21))
GOTO PRVINS
+7 IF $PIECE(^AUPNMCD(DA,21),U)]""
SET AGNAME=$PIECE(^(21),U)
DO NAMECVT^AGTX1
SET $PIECE(AGTEMP(5),U,10)=AGLN
SET $PIECE(AGTEMP(5),U,11)=AGFN
SET $PIECE(AGTEMP(5),U,12)=AGMN
+8 IF $PIECE(^AUPNMCD(DA,21),U,2)]""
SET AGVAL=$PIECE(^(21),U,2)
DO D8CV^AGTX1
SET $PIECE(AGTEMP(5),U,14)=AGVAL
PRVINS ;
+1 IF $DATA(^AUPNPRVT(AGRCT,0))
SET $PIECE(AGTEMP(2),U,24)="Y"
+2 SET $PIECE(AGTEMP(2),U,22)=$PIECE($GET(^DPT(DFN,"VET")),U,1)
CHSELG ;
+1 SET AGMEDDT=$PIECE(^AUPNPAT(AGRCT,0),U,4)
+2 IF $GET(AGMEDDT)
SET AGMEDDT=AGMEDDT+17000000
+3 IF $PIECE($GET(^AUPNPAT(AGRCT,11)),U,12)="C"
SET $PIECE(AGTEMP(2),U,25)="Y"
SET $PIECE(AGTEMP(2),U,27)=AG("MODCODE")
SET $PIECE(AGTEMP(2),U,28)=AGMEDDT
+4 KILL AGMEDDT
+5 IF $DATA(^AUPNPAT(AGRCT,11))
SET $PIECE(AGTEMP(2),U,29)=$PIECE(^(11),U,12)
IF $PIECE(^AUPNPAT(AGRCT,0),U,2)
SET $PIECE(AGTEMP(2),U,30)=$PIECE(^(0),U,2)+17000000
+6 ;>GOTO PROC HRNS
GOTO ^AGTX3
PTA ;
+1 IF '$DATA(AGCT)
QUIT
+2 IF (AGCT'?1A.A)
QUIT
+3 IF $DATA(AGFLG(AGCT))
QUIT
+4 SET AGN1=$SELECT(AGCT="A":6,AGCT="B":10,AGCT="AB":14,AGCT="MM":18,1:0)
+5 IF AGN1=0
QUIT
+6 SET $PIECE(AGTEMP(2),U,AGN1)="Y"
SET $PIECE(AGTEMP(2),U,AGN1+1)=AGNUMB
SET $PIECE(AGTEMP(2),U,AGN1+2)=""
+7 DO D8CV^AGTX1
SET $PIECE(AGTEMP(2),U,AGN1+3)=AGVAL
+8 IF $GET(AGELGEND)
SET AGELGEND=AGELGEND+17000000
+9 SET $PIECE(AGTEMP(5),U,$SELECT(AGCT="A":15,AGCT="B":16,AGCT="AB":17,AGCT="MM":18))=AGELGEND
+10 SET AGFLG(AGCT)=""
+11 QUIT
