- 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
