AGTX1 ; IHS/ASDS/EFG - EXPORT REG DATA CONT'D ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
S2A ;EP
K AGTEMP
S2AA S AGRCT=$O(^AGCHDFN(AGRCT)),DFN=AGRCT ;> LOOP PATIENTS
G JOBEND^AGTX4:AGRCT="" S AG("SITE")=0 ;>END JOB
S2AAA ;EP -
S AG("SITE")=$O(^AGCHDFN(AGRCT,AG("SITE"))) ;> LOOP SITE
G S2AA:AG("SITE")="" S AGDTS=0
D ^AGTX5 ;>PROC HRN/INS | D/M/C
G:$P(^DPT(AGRCT,0),U,19) S2AA ;> MERGED PATIENT
CKDEL ;>CHECK DEL
I AG("TXDEL") K AG("TXDEL") G S2AAA ;>DEL | NO DEMOG SENT
S AG("MODCODE")=1
CHK1 ;> Check Demog
K AGTEMP G S2AAA:'$D(^AUPNPAT(AGRCT,0))!'$D(^AUPNPAT(AGRCT,41,AG("SITE"),0))!'$D(^AUTTLOC(AG("SITE")))!'$D(^AUPNPAT(AGRCT,11)) ;> BAD DEMOG
I '$D(^DPT(AGRCT,.11)) S AGDFN16="",AGBAD16=AGBAD16+1
I '$D(^AUPNPAT(AGRCT,51)) S AGDFN51="",AGBAD51=AGBAD51+1
R1P1 ;> Gen RG1
G:$D(^AGCHDFN(AGRCT,"RG1")) S2AAA ;>prev sent | merged |
S ^AGCHDFN(AGRCT,"RG1")="" ;>mark as prev sent
ALL ;EP - From AGTXALL to extract all pt's.
S AGTEMP(1)="RG1" D HRNPFAC
S AGNAME=$P(^DPT(AGRCT,0),U)
S AGNAME=$TR(AGNAME,"abcdefghijklmnopqrstuvwxyz)(/","ABCDEFGHIJKLMNOPQRSTUVWXYZ---")
D NAMECVT S $P(AGTEMP(1),U,4)=AGLN,$P(AGTEMP(1),U,5)=AGFN,$P(AGTEMP(1),U,6)=AGMN
S X=$P($G(^AUPNPAT(AGRCT,11)),U,11) I +X<1 G R1P8
S $P(AGTEMP(1),U,7)=$P($G(^AUTTBEN(X,0)),U,2)
R1P8 ;Get date of Birth from DPT-put into 8th piece of transaction file-RG1
S AGVAL=$P(^DPT(AGRCT,0),U,3) D D8CV S $P(AGTEMP(1),U,8)=AGVAL
S $P(AGTEMP(1),U,9)=$P(^DPT(AGRCT,0),U,2)
S AGVAL=$P(^DPT(AGRCT,0),U,9) I AGVAL["-" S AGVAL=$E(AGVAL,1,3)_$E(AGVAL,5,6)_$E(AGVAL,8,11)
S $P(AGTEMP(1),U,10)=AGVAL
S X=$P($G(^AUPNPAT(AGRCT,11)),U,8) I +X<1 S $P(AGTEMP(1),U,11)="" G R1P12
S $P(AGTEMP(1),U,11)=$P(^AUTTTRI(X,0),U,2)
R1P12 ;
S AGVAL=$P($G(^AUPNPAT(AGRCT,11)),U,10) I AGVAL]"" D QNTCVT I Y]"" S $P(AGTEMP(1),U,12)=Y
I $D(^DPT(AGRCT,.24)) S AGNAME=$P(^DPT(AGRCT,.24),U),(AGLN,AGFN,AGMN)="" D NAMECVT:AGNAME]"" S $P(AGTEMP(1),U,13)=AGLN,$P(AGTEMP(1),U,14)=AGFN,$P(AGTEMP(1),U,15)=$E(AGMN,1,1)
R1P16 I $D(^AUPNPAT(AGRCT,11)) S X=$P(^(11),"^",17) I X,$D(^AUTTCOM(X,0)) S AGVAL=$P(^AUTTCOM(X,0),U,8),$P(AGTEMP(1),U,16)=$E(AGVAL,5,7)_$E(AGVAL,3,4)_$E(AGVAL,1,2)
R1P17 I '$D(^DPT(AGRCT,.11)) G R1P20A
S $P(AGTEMP(1),U,17)=$P(^DPT(AGRCT,.11),U),$P(AGTEMP(1),U,18)=$P(^(.11),U,4),X=$P(^(.11),U,5)
I +X<1 G R1P20
S $P(AGTEMP(1),U,19)=$P(^DIC(5,X,0),U,2)
R1P20 S AGTX=$P(^DPT(AGRCT,.11),U,6),AGTX=$TR(AGTX,"-"),$P(AGTEMP(1),U,20)=AGTX
R1P20A D SETAGTX G R2P1^AGTX2
HRNPFAC ;>HRN PARENT FAC
;substitute for a HRN at a parent facility in this data base
S DFN=AGRCT,AGRSITE=AG("SITE") D ^AGTXRHRN ;get a registering HRN
I 'AGRHRN K AGRSITE D ^AGTXRHRN ;get a registering fac & hrn
S:AGRSITE $P(AGTEMP(1),U,2)=$P($G(^AUTTLOC(AGRSITE,0)),U,10)
S $P(AGTEMP(1),U,3)=AGRHRN
Q ;found proper FAC:HRN
K AGRSITE,AGRHRN
EHRNPFAC Q
SETAGTX ;>SET AGTXDATA
I '$D(ZTQUEUED),'$G(AGTXALL) W:AGOUTFLG !,AGTEMP(1) I 'AGOUTFLG,AGROUT#10=0 X XY W AGROUT
I $G(AGTXALL) S T(1)=$P(AGTEMP(1),U,1)_U_U_$P(AGTEMP(1),U,2,999) D SET^AGTXALL(1) KILL T(1) Q
S AGROUT=AGROUT+1,AGTEMP(1)=$P(AGTEMP(1),U,1)_U_$$UID^AGTXID(AGRCT)_U_$P(AGTEMP(1),U,2,999),$P(AGTEMP(1),U,21)=$P(AGTEMP(1),U,21),^AGTXDATA(AGROUT)=AGTEMP(1)
Q
QNTCVT S (Y,X)="" I +AGVAL>0 S X=$P(AGVAL,"/",1)/$P(AGVAL,"/",2)
QUANTIHS S Y=$S((AGVAL="FULL"!(X=1)):1,AGVAL="NONE":5,AGVAL="UNSPECIFIED":6,AGVAL="UNKNOWN":7,+AGVAL'>0:7,1:Y) Q:Y]""
S Y=$S(X'<.5:2,X'<.25:3,X'<.125:4,X<.125:4,1:Y)
Q
D6CV ;EP -
S AGVAL=$E(AGVAL,4,7)_$E(AGVAL,2,3) Q
D7CV ;EP -
S AGCC=$E(AGVAL,1,3),AGCC=$E((1700+AGCC),2,4)
S AGVAL=$E(AGVAL,4,7)_AGCC Q
D8CV ;EP - date conversion from fileman format to CCYYMMDD
I $G(AGVAL) S AGVAL=AGVAL+17000000 ;Y2000
Q
NAMECVT ;EP -
S AGN1=$P(AGNAME,",",1),AGN2=$P(AGNAME,",",2),AGN3=$P(AGNAME,",",3)
S AGLN=AGN1,AGFN=$P(AGN2," ",1),AGMN=$P(AGN2," ",2)
I AGN3]"" S AGLN=AGLN_" "_AGN3
Q
AGTX1 ; IHS/ASDS/EFG - EXPORT REG DATA CONT'D ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
S2A ;EP
+1 KILL AGTEMP
S2AA ;> LOOP PATIENTS
SET AGRCT=$ORDER(^AGCHDFN(AGRCT))
SET DFN=AGRCT
+1 ;>END JOB
IF AGRCT=""
GOTO JOBEND^AGTX4
SET AG("SITE")=0
S2AAA ;EP -
+1 ;> LOOP SITE
SET AG("SITE")=$ORDER(^AGCHDFN(AGRCT,AG("SITE")))
+2 IF AG("SITE")=""
GOTO S2AA
SET AGDTS=0
+3 ;>PROC HRN/INS | D/M/C
DO ^AGTX5
+4 ;> MERGED PATIENT
IF $PIECE(^DPT(AGRCT,0),U,19)
GOTO S2AA
CKDEL ;>CHECK DEL
+1 ;>DEL | NO DEMOG SENT
IF AG("TXDEL")
KILL AG("TXDEL")
GOTO S2AAA
+2 SET AG("MODCODE")=1
CHK1 ;> Check Demog
+1 ;> BAD DEMOG
KILL AGTEMP
IF '$DATA(^AUPNPAT(AGRCT,0))!'$DATA(^AUPNPAT(AGRCT,41,AG("SITE"),0))!'$DATA(^AUTTLOC(AG("SITE")))!'$DATA(^AUPNPAT(AGRCT,11))
GOTO S2AAA
+2 IF '$DATA(^DPT(AGRCT,.11))
SET AGDFN16=""
SET AGBAD16=AGBAD16+1
+3 IF '$DATA(^AUPNPAT(AGRCT,51))
SET AGDFN51=""
SET AGBAD51=AGBAD51+1
R1P1 ;> Gen RG1
+1 ;>prev sent | merged |
IF $DATA(^AGCHDFN(AGRCT,"RG1"))
GOTO S2AAA
+2 ;>mark as prev sent
SET ^AGCHDFN(AGRCT,"RG1")=""
ALL ;EP - From AGTXALL to extract all pt's.
+1 SET AGTEMP(1)="RG1"
DO HRNPFAC
+2 SET AGNAME=$PIECE(^DPT(AGRCT,0),U)
+3 SET AGNAME=$TRANSLATE(AGNAME,"abcdefghijklmnopqrstuvwxyz)(/","ABCDEFGHIJKLMNOPQRSTUVWXYZ---")
+4 DO NAMECVT
SET $PIECE(AGTEMP(1),U,4)=AGLN
SET $PIECE(AGTEMP(1),U,5)=AGFN
SET $PIECE(AGTEMP(1),U,6)=AGMN
+5 SET X=$PIECE($GET(^AUPNPAT(AGRCT,11)),U,11)
IF +X<1
GOTO R1P8
+6 SET $PIECE(AGTEMP(1),U,7)=$PIECE($GET(^AUTTBEN(X,0)),U,2)
R1P8 ;Get date of Birth from DPT-put into 8th piece of transaction file-RG1
+1 SET AGVAL=$PIECE(^DPT(AGRCT,0),U,3)
DO D8CV
SET $PIECE(AGTEMP(1),U,8)=AGVAL
+2 SET $PIECE(AGTEMP(1),U,9)=$PIECE(^DPT(AGRCT,0),U,2)
+3 SET AGVAL=$PIECE(^DPT(AGRCT,0),U,9)
IF AGVAL["-"
SET AGVAL=$EXTRACT(AGVAL,1,3)_$EXTRACT(AGVAL,5,6)_$EXTRACT(AGVAL,8,11)
+4 SET $PIECE(AGTEMP(1),U,10)=AGVAL
+5 SET X=$PIECE($GET(^AUPNPAT(AGRCT,11)),U,8)
IF +X<1
SET $PIECE(AGTEMP(1),U,11)=""
GOTO R1P12
+6 SET $PIECE(AGTEMP(1),U,11)=$PIECE(^AUTTTRI(X,0),U,2)
R1P12 ;
+1 SET AGVAL=$PIECE($GET(^AUPNPAT(AGRCT,11)),U,10)
IF AGVAL]""
DO QNTCVT
IF Y]""
SET $PIECE(AGTEMP(1),U,12)=Y
+2 IF $DATA(^DPT(AGRCT,.24))
SET AGNAME=$PIECE(^DPT(AGRCT,.24),U)
SET (AGLN,AGFN,AGMN)=""
IF AGNAME]""
DO NAMECVT
SET $PIECE(AGTEMP(1),U,13)=AGLN
SET $PIECE(AGTEMP(1),U,14)=AGFN
SET $PIECE(AGTEMP(1),U,15)=$EXTRACT(AGMN,1,1)
R1P16 IF $DATA(^AUPNPAT(AGRCT,11))
SET X=$PIECE(^(11),"^",17)
IF X
IF $DATA(^AUTTCOM(X,0))
SET AGVAL=$PIECE(^AUTTCOM(X,0),U,8)
SET $PIECE(AGTEMP(1),U,16)=$EXTRACT(AGVAL,5,7)_$EXTRACT(AGVAL,3,4)_$EXTRACT(AGVAL,1,2)
R1P17 IF '$DATA(^DPT(AGRCT,.11))
GOTO R1P20A
+1 SET $PIECE(AGTEMP(1),U,17)=$PIECE(^DPT(AGRCT,.11),U)
SET $PIECE(AGTEMP(1),U,18)=$PIECE(^(.11),U,4)
SET X=$PIECE(^(.11),U,5)
+2 IF +X<1
GOTO R1P20
+3 SET $PIECE(AGTEMP(1),U,19)=$PIECE(^DIC(5,X,0),U,2)
R1P20 SET AGTX=$PIECE(^DPT(AGRCT,.11),U,6)
SET AGTX=$TRANSLATE(AGTX,"-")
SET $PIECE(AGTEMP(1),U,20)=AGTX
R1P20A DO SETAGTX
GOTO R2P1^AGTX2
HRNPFAC ;>HRN PARENT FAC
+1 ;substitute for a HRN at a parent facility in this data base
+2 ;get a registering HRN
SET DFN=AGRCT
SET AGRSITE=AG("SITE")
DO ^AGTXRHRN
+3 ;get a registering fac & hrn
IF 'AGRHRN
KILL AGRSITE
DO ^AGTXRHRN
+4 IF AGRSITE
SET $PIECE(AGTEMP(1),U,2)=$PIECE($GET(^AUTTLOC(AGRSITE,0)),U,10)
+5 SET $PIECE(AGTEMP(1),U,3)=AGRHRN
+6 ;found proper FAC:HRN
QUIT
+7 KILL AGRSITE,AGRHRN
EHRNPFAC QUIT
SETAGTX ;>SET AGTXDATA
+1 IF '$DATA(ZTQUEUED)
IF '$GET(AGTXALL)
IF AGOUTFLG
WRITE !,AGTEMP(1)
IF 'AGOUTFLG
IF AGROUT#10=0
XECUTE XY
WRITE AGROUT
+2 IF $GET(AGTXALL)
SET T(1)=$PIECE(AGTEMP(1),U,1)_U_U_$PIECE(AGTEMP(1),U,2,999)
DO SET^AGTXALL(1)
KILL T(1)
QUIT
+3 SET AGROUT=AGROUT+1
SET AGTEMP(1)=$PIECE(AGTEMP(1),U,1)_U_$$UID^AGTXID(AGRCT)_U_$PIECE(AGTEMP(1),U,2,999)
SET $PIECE(AGTEMP(1),U,21)=$PIECE(AGTEMP(1),U,21)
SET ^AGTXDATA(AGROUT)=AGTEMP(1)
+4 QUIT
QNTCVT SET (Y,X)=""
IF +AGVAL>0
SET X=$PIECE(AGVAL,"/",1)/$PIECE(AGVAL,"/",2)
QUANTIHS SET Y=$SELECT((AGVAL="FULL"!(X=1)):1,AGVAL="NONE":5,AGVAL="UNSPECIFIED":6,AGVAL="UNKNOWN":7,+AGVAL'>0:7,1:Y)
IF Y]""
QUIT
+1 SET Y=$SELECT(X'<.5:2,X'<.25:3,X'<.125:4,X<.125:4,1:Y)
+2 QUIT
D6CV ;EP -
+1 SET AGVAL=$EXTRACT(AGVAL,4,7)_$EXTRACT(AGVAL,2,3)
QUIT
D7CV ;EP -
+1 SET AGCC=$EXTRACT(AGVAL,1,3)
SET AGCC=$EXTRACT((1700+AGCC),2,4)
+2 SET AGVAL=$EXTRACT(AGVAL,4,7)_AGCC
QUIT
D8CV ;EP - date conversion from fileman format to CCYYMMDD
+1 ;Y2000
IF $GET(AGVAL)
SET AGVAL=AGVAL+17000000
+2 QUIT
NAMECVT ;EP -
+1 SET AGN1=$PIECE(AGNAME,",",1)
SET AGN2=$PIECE(AGNAME,",",2)
SET AGN3=$PIECE(AGNAME,",",3)
+2 SET AGLN=AGN1
SET AGFN=$PIECE(AGN2," ",1)
SET AGMN=$PIECE(AGN2," ",2)
+3 IF AGN3]""
SET AGLN=AGLN_" "_AGN3
+4 QUIT
