- AGTX5 ; IHS/ASDS/EFG - EXPORT REG DATA CONT'D APR 14,1995 ;
- ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
- ;
- START ;
- S (AGDTS,AGFHRN,AGLHRN)=0,AG("TXMERG")="",AG("TXDEL")=""
- I '$D(^AGCHDFN(DFN,"CK")) S DFN=AGRCT K AG("ER") D ^AGDATCK I $D(AG("ER")) K AG("ER") S ^AGCHDFN(AGRCT,"RG1")="" ;mark to not send rg1 if datchk fails
- AGDTS ;
- F S AGDTS=$O(^AGCHDFN(AGRCT,AG("SITE"),AGDTS)) Q:'+AGDTS D RG3MGR ;>LOOP DATE/TIME | one patient
- G BLDRG3 ;>PROC RG3
- RG3MGR ;>HRN/INS D/M/C | RG5
- S AGX=^AGCHDFN(AGRCT,AG("SITE"),AGDTS)
- S:AGX="NEW" AG("TXNEW")=1 ;mark so as not to send any Change HRNs
- D:($D(^AGCHDFN(AGRCT,AG("SITE"),AGDTS))>1) DELINS ;>DEL INS | RG5
- Q:'+AGX ;>NO HRN D/M/C
- I $P(AGX,"^",6) S AG("TXMERG")=AGDTS Q ;>MERG
- Q:'$D(^AGFAC("AC",AG("SITE"))) ;>NOT PARENT FAC
- I $P(AGX,"^",3)="" S AG("TXDEL")=AGDTS Q ;>DEL HRN/PAT
- S:'AGFHRN AGFHRN=$P(AGX,"^",2)
- S AG("CHRN")=AGDTS,AGLHRN=$P(AGX,"^",3)
- Q
- BLDRG3 ;EP - Build various RG3s
- TXCHRN ;>HRN CHANGES
- G:'$D(AG("CHRN")) TXMERG ;>NO HRN CHANGE
- G:'$G(AG("TXNEW")) TXMERG ;new pat - send no Chng HRN
- S AGDTS=AG("CHRN")
- D SETRG3
- S $P(AGTEMP(3),U,3,4)=AGFHRN_"^"_AGLHRN
- D SETAGTX
- TXMERG ;>MERGS
- G:AG("TXMERG")="" TXDEL ;----- ;>NO MERG
- S AGDTS=AG("TXMERG"),AGX=^AGCHDFN(AGRCT,AG("SITE"),AGDTS)
- D SETRG3,SETAGTX
- S ^AGCHDFN(AGRCT,"RG1")="" ;mark to not send demog for merged patient
- TXDEL ;>DEL PAT
- G:AG("TXDEL")="" FIN ;>NO DEL HRN
- S AGDTS=AG("TXDEL"),AGX=^AGCHDFN(AGRCT,AG("SITE"),AGDTS),AGX1=$P(^AUTTLOC(+AGX,0),U,10)
- S AGTEMP(3)="RG3^"_AGX1_U_$P(AGX,U,2,99) D SETAGTX S ^AGCHDFN(AGRCT,"RG1")=""
- FIN ;>CLEAN UP | RET AG("TXDEL")
- K AGDTS,AGRHRN,AGLHRN,AG("MERG"),AG("CHRN"),AG("TXNEW")
- Q
- DELINS ;INSURANCE COVERAGE DELETES ;>LOOP INS
- S AG("SUB")=""
- F AGZ("I")=1:1 S AG("SUB")=$O(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB"))) Q:AG("SUB")="" D DELCOV
- Q
- DELCOV ;>DEL INS COV | AGTEMP(5)=RG5^..
- Q:($P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,2)="")!($P(^(AG("SUB")),U,3)="")
- S AGTXSUB=AG("SUB")
- I $P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U)="MCARE" Q:'$D(^AUTTMCS($P(^(AGTXSUB),U,3)))
- I $P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U)="MCAID" Q:'$D(^DIC(5,$P(^(AGTXSUB),U,3)))
- S AGTEMP(5)="RG5",$P(AGTEMP(5),U,2)=$E($P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,2),1,14),AGCT=$P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,6),AGELGEND=$P(^(AG("SUB")),U,5)
- S1 ;
- S $P(AGTEMP(5),U,2)=$P(AGTEMP(5),U,2)_$S($P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U)="MCARE":$P(^AUTTMCS($P(^(AG("SUB")),U,3),0),U),1:"")
- S AGVAL=$P(^DPT(AGRCT,0),U,3) D D8CV^AGTX1
- S $P(AGTEMP(5),U,4)=$S(AGCT="A":1,AGCT="B":2,AGCT="AB":3,1:4)
- S $P(AGTEMP(5),U,5)=AGVAL
- S $P(AGTEMP(5),U,6)=$$Y2KD2($P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,4))
- S $P(AGTEMP(5),U,15,18)=""
- S $P(AGTEMP(5),U,$S(AGCT="A":15,AGCT="B":16,AGCT="AB":17,1:18))=$$Y2KD2(AGELGEND)
- RG5 ;>AGTXDATA=AGTEMP(5)
- S AGROUT=AGROUT+1,AGTEMP(5)=$P(AGTEMP(5),U,1)_U_$$UID^AGTXID(AGRCT)_U_$P(AGTEMP(5),U,2,999),$P(AGTEMP(5),U,20)=$P(^AUTTLOC(AGTXSITE,0),U,10),^AGTXDATA(AGROUT)=AGTEMP(5),AG("TOT")=AG("TOT")+1
- W:AGOUTFLG !,AGTEMP(5)
- I 'AGOUTFLG,AGROUT#10=0 X XY W AGROUT
- Q
- SETRG3 ;>AGTEMP(3)=RG3^..
- S AGTEMP(3)="RG3^"_$P(^AUTTLOC($P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS),U),0),U,10)_U_$P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS),U,2,5)_U_""
- I $P(^AGCHDFN(AGRCT,AG("SITE"),AGDTS),U,6)]"" S $P(AGTEMP(3),U,7,8)=1_"^"_$P(^AUTTLOC($P(AGX,U,6),0),U,10)
- Q
- SETAGTX ;>AGTXDATA=AGTEMP(3)
- I '$D(ZTQUEUED) W:AGOUTFLG !,AGTEMP(3) I 'AGOUTFLG,AGROUT#10=0 X XY W AGROUT
- S AGROUT=AGROUT+1,AGTEMP(3)=$P(AGTEMP(3),U,1)_U_$$UID^AGTXID(AGRCT)_U_$P(AGTEMP(3),U,2,999),$P(AGTEMP(3),U,9)=$P(AGTEMP(3),U,9),^AGTXDATA(AGROUT)=AGTEMP(3),AG("TOT")=$G(AG("TOT"))+1
- Q
- Y2KD2(X) ;EP - date from fileman to Y2K format Y=CCYYMMDD
- N Y
- I X="" Q X
- S Y=($E(X,1,3)+1700)_$E(X,4,7)
- Q Y
- AGTX5 ; IHS/ASDS/EFG - EXPORT REG DATA CONT'D APR 14,1995 ;
- +1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
- +2 ;
- START ;
- +1 SET (AGDTS,AGFHRN,AGLHRN)=0
- SET AG("TXMERG")=""
- SET AG("TXDEL")=""
- +2 ;mark to not send rg1 if datchk fails
- IF '$DATA(^AGCHDFN(DFN,"CK"))
- SET DFN=AGRCT
- KILL AG("ER")
- DO ^AGDATCK
- IF $DATA(AG("ER"))
- KILL AG("ER")
- SET ^AGCHDFN(AGRCT,"RG1")=""
- AGDTS ;
- +1 ;>LOOP DATE/TIME | one patient
- FOR
- SET AGDTS=$ORDER(^AGCHDFN(AGRCT,AG("SITE"),AGDTS))
- IF '+AGDTS
- QUIT
- DO RG3MGR
- +2 ;>PROC RG3
- GOTO BLDRG3
- RG3MGR ;>HRN/INS D/M/C | RG5
- +1 SET AGX=^AGCHDFN(AGRCT,AG("SITE"),AGDTS)
- +2 ;mark so as not to send any Change HRNs
- IF AGX="NEW"
- SET AG("TXNEW")=1
- +3 ;>DEL INS | RG5
- IF ($DATA(^AGCHDFN(AGRCT,AG("SITE"),AGDTS))>1)
- DO DELINS
- +4 ;>NO HRN D/M/C
- IF '+AGX
- QUIT
- +5 ;>MERG
- IF $PIECE(AGX,"^",6)
- SET AG("TXMERG")=AGDTS
- QUIT
- +6 ;>NOT PARENT FAC
- IF '$DATA(^AGFAC("AC",AG("SITE")))
- QUIT
- +7 ;>DEL HRN/PAT
- IF $PIECE(AGX,"^",3)=""
- SET AG("TXDEL")=AGDTS
- QUIT
- +8 IF 'AGFHRN
- SET AGFHRN=$PIECE(AGX,"^",2)
- +9 SET AG("CHRN")=AGDTS
- SET AGLHRN=$PIECE(AGX,"^",3)
- +10 QUIT
- BLDRG3 ;EP - Build various RG3s
- TXCHRN ;>HRN CHANGES
- +1 ;>NO HRN CHANGE
- IF '$DATA(AG("CHRN"))
- GOTO TXMERG
- +2 ;new pat - send no Chng HRN
- IF '$GET(AG("TXNEW"))
- GOTO TXMERG
- +3 SET AGDTS=AG("CHRN")
- +4 DO SETRG3
- +5 SET $PIECE(AGTEMP(3),U,3,4)=AGFHRN_"^"_AGLHRN
- +6 DO SETAGTX
- TXMERG ;>MERGS
- +1 ;----- ;>NO MERG
- IF AG("TXMERG")=""
- GOTO TXDEL
- +2 SET AGDTS=AG("TXMERG")
- SET AGX=^AGCHDFN(AGRCT,AG("SITE"),AGDTS)
- +3 DO SETRG3
- DO SETAGTX
- +4 ;mark to not send demog for merged patient
- SET ^AGCHDFN(AGRCT,"RG1")=""
- TXDEL ;>DEL PAT
- +1 ;>NO DEL HRN
- IF AG("TXDEL")=""
- GOTO FIN
- +2 SET AGDTS=AG("TXDEL")
- SET AGX=^AGCHDFN(AGRCT,AG("SITE"),AGDTS)
- SET AGX1=$PIECE(^AUTTLOC(+AGX,0),U,10)
- +3 SET AGTEMP(3)="RG3^"_AGX1_U_$PIECE(AGX,U,2,99)
- DO SETAGTX
- SET ^AGCHDFN(AGRCT,"RG1")=""
- FIN ;>CLEAN UP | RET AG("TXDEL")
- +1 KILL AGDTS,AGRHRN,AGLHRN,AG("MERG"),AG("CHRN"),AG("TXNEW")
- +2 QUIT
- DELINS ;INSURANCE COVERAGE DELETES ;>LOOP INS
- +1 SET AG("SUB")=""
- +2 FOR AGZ("I")=1:1
- SET AG("SUB")=$ORDER(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")))
- IF AG("SUB")=""
- QUIT
- DO DELCOV
- +3 QUIT
- DELCOV ;>DEL INS COV | AGTEMP(5)=RG5^..
- +1 IF ($PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,2)="")!($PIECE(^(AG("SUB")),U,3)="")
- QUIT
- +2 SET AGTXSUB=AG("SUB")
- +3 IF $PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U)="MCARE"
- IF '$DATA(^AUTTMCS($PIECE(^(AGTXSUB),U,3)))
- QUIT
- +4 IF $PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U)="MCAID"
- IF '$DATA(^DIC(5,$PIECE(^(AGTXSUB),U,3)))
- QUIT
- +5 SET AGTEMP(5)="RG5"
- SET $PIECE(AGTEMP(5),U,2)=$EXTRACT($PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,2),1,14)
- SET AGCT=$PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,6)
- SET AGELGEND=$PIECE(^(AG("SUB")),U,5)
- S1 ;
- +1 SET $PIECE(AGTEMP(5),U,2)=$PIECE(AGTEMP(5),U,2)_$SELECT($PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U)="MCARE":$PIECE(^AUTTMCS($PIECE(^(AG("SUB")),U,3),0),U),1:"")
- +2 SET AGVAL=$PIECE(^DPT(AGRCT,0),U,3)
- DO D8CV^AGTX1
- +3 SET $PIECE(AGTEMP(5),U,4)=$SELECT(AGCT="A":1,AGCT="B":2,AGCT="AB":3,1:4)
- +4 SET $PIECE(AGTEMP(5),U,5)=AGVAL
- +5 SET $PIECE(AGTEMP(5),U,6)=$$Y2KD2($PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS,AG("SUB")),U,4))
- +6 SET $PIECE(AGTEMP(5),U,15,18)=""
- +7 SET $PIECE(AGTEMP(5),U,$SELECT(AGCT="A":15,AGCT="B":16,AGCT="AB":17,1:18))=$$Y2KD2(AGELGEND)
- RG5 ;>AGTXDATA=AGTEMP(5)
- +1 SET AGROUT=AGROUT+1
- SET AGTEMP(5)=$PIECE(AGTEMP(5),U,1)_U_$$UID^AGTXID(AGRCT)_U_$PIECE(AGTEMP(5),U,2,999)
- SET $PIECE(AGTEMP(5),U,20)=$PIECE(^AUTTLOC(AGTXSITE,0),U,10)
- SET ^AGTXDATA(AGROUT)=AGTEMP(5)
- SET AG("TOT")=AG("TOT")+1
- +2 IF AGOUTFLG
- WRITE !,AGTEMP(5)
- +3 IF 'AGOUTFLG
- IF AGROUT#10=0
- XECUTE XY
- WRITE AGROUT
- +4 QUIT
- SETRG3 ;>AGTEMP(3)=RG3^..
- +1 SET AGTEMP(3)="RG3^"_$PIECE(^AUTTLOC($PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS),U),0),U,10)_U_$PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS),U,2,5)_U_""
- +2 IF $PIECE(^AGCHDFN(AGRCT,AG("SITE"),AGDTS),U,6)]""
- SET $PIECE(AGTEMP(3),U,7,8)=1_"^"_$PIECE(^AUTTLOC($PIECE(AGX,U,6),0),U,10)
- +3 QUIT
- SETAGTX ;>AGTXDATA=AGTEMP(3)
- +1 IF '$DATA(ZTQUEUED)
- IF AGOUTFLG
- WRITE !,AGTEMP(3)
- IF 'AGOUTFLG
- IF AGROUT#10=0
- XECUTE XY
- WRITE AGROUT
- +2 SET AGROUT=AGROUT+1
- SET AGTEMP(3)=$PIECE(AGTEMP(3),U,1)_U_$$UID^AGTXID(AGRCT)_U_$PIECE(AGTEMP(3),U,2,999)
- SET $PIECE(AGTEMP(3),U,9)=$PIECE(AGTEMP(3),U,9)
- SET ^AGTXDATA(AGROUT)=AGTEMP(3)
- SET AG("TOT")=$GET(AG("TOT"))+1
- +3 QUIT
- Y2KD2(X) ;EP - date from fileman to Y2K format Y=CCYYMMDD
- +1 NEW Y
- +2 IF X=""
- QUIT X
- +3 SET Y=($EXTRACT(X,1,3)+1700)_$EXTRACT(X,4,7)
- +4 QUIT Y
