- 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
