AGELA1 ; IHS/ASDS/EFG - Eligibility Display (CONT) ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
MCD S AGEL=""
F AGEL("I")=1:1 S AGEL=$O(^AUPNMCD("C",AGELP("PH"),AGEL)) Q:'+AGEL D
.S AGEL(0)=^AUPNMCD(AGEL,0) Q:'$D(^DPT(+AGEL(0),0))
.S AGELP("MCD")=AGEL
.W !,AGEL("I")+12,") ",$P(^DPT(+AGEL(0),0),U)
.I $D(DUZ(2)),$D(^AUPNPAT(AGEL(0),41,DUZ(2),0)) W ?35,$P(^(0),U,2)
.S AGELP(+AGEL(0))=(AGEL("I")+12)_U_AGEL
.W ?44
.W $S($P(AGEL(0),U,6)]"":$P(^AUTTRLSH($P(AGEL(0),U,6),0),U),1:"SELF")
.S (AGEL("HIT"),AGEL(1),AGEL("LAST"),AGEL("NUM"))=0
.F S AGEL(1)=$O(^AUPNMCD(AGEL,11,AGEL(1))) Q:'+AGEL(1) S AGEL(10)=^(AGEL(1),0) D Q:AGEL("HIT")
..I $P(AGEL(10),U,2)="" S AGEL("HIT")=1,AGEL("NUM")=AGEL(1) Q
..I $P(AGEL(10),U,2)>AGEL("LAST") D
...S AGEL("LAST")=$P(AGEL(10),U,2),AGEL("NUM")=AGEL(1)
.I AGEL("NUM") D
..S AGEL("DT")=$P(^AUPNMCD(AGEL,11,AGEL("NUM"),0),U)
..S $P(AGELP(+AGEL(0)),U,3)=AGEL("DT")
..D DT
..W ?62,AGEL("DT")
..I $P(^AUPNMCD(AGEL,11,AGEL("NUM"),0),U,2)]"" S AGEL("DT")=$P(^AUPNMCD(AGEL,11,AGEL("NUM"),0),U,2) D DT W ?71,"/",AGEL("DT")
Q
PRVT S AGEL=""
F AGEL("I")=1:1 S AGEL=$O(^AUPNPRVT("C",AGELP("PH"),AGEL)) Q:'+AGEL S AGEL(1)=$O(^(AGEL,"")) D
.I '$D(^AUPNPRVT(AGEL,0)) K ^AUPNPRVT("C",AGELP("PH"),AGEL) Q
.S AGEL(0)=$G(^AUPNPRVT(AGEL,0))
.S AGEL(10)=$G(^AUPNPRVT(AGEL,11,AGEL(1),0))
.S AGEL(2)=$G(^AUPNPRVT(AGEL,11,AGEL(1),2))
.S AGELP("PI")=AGEL
.;# and member name
.W !,AGEL("I")+12,") "
.W:$P(AGEL(0),U)'="" $E($P($G(^DPT($P(AGEL(0),U),0)),U),1,17)
.;new person code
.W:$P(AGEL(10),U,12)]"" ?22,$P(AGEL(10),U,12)
.;member #
.I $P($G(AGEL(2)),U)="",($G(AGEL)=$G(AGELP("PHPAT"))) D
..S DIE="^AUPNPRVT("_AGEL_",11,"
..S DA=AGEL(1)
..S DR="21////"_$P($G(^AUPN3PPH(AGELP("PH"),0)),U,4)
..D ^DIE
..S AGEL(2)=$G(^AUPNPRVT(AGEL,11,AGEL(1),2))
.W:$P(AGEL(2),U)]"" ?26,$E($P(AGEL(2),U),1,13)
.;hrn
.I $D(DUZ(2)),$D(^AUPNPAT(AGEL(0),41,DUZ(2),0)) D
..W ?42,$P(^AUPNPAT(AGEL(0),41,DUZ(2),0),U,2)
.S AGELP(+AGEL(0))=(AGEL("I")+12)_U_AGEL(1)
.;relationship
.W ?50
.S AGREL=$P(AGEL(10),U,5)
.I AGREL'="" D
..S AGREL=$S($P($G(^AUTTRLSH(AGREL,0)),U)'="":$P(^AUTTRLSH(AGREL,0),U),1:"SELF")
.E S AGREL=""
.W $E(AGREL,1,9)
.;from/thru
.S AGEL("DT")=$P(AGEL(10),U,6)
.D DT
.W ?60,AGEL("DT")
.S AGEL("DT")=$P(AGEL(10),U,7)
.D DT
.I AGEL("DT")]"" W "-",AGEL("DT")
Q
DT ;
I AGEL("DT")]"" S AGEL("DT")=$$FMTE^XLFDT(AGEL("DT"),5)
Q
AGELA1 ; IHS/ASDS/EFG - Eligibility Display (CONT) ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
MCD SET AGEL=""
+1 FOR AGEL("I")=1:1
SET AGEL=$ORDER(^AUPNMCD("C",AGELP("PH"),AGEL))
IF '+AGEL
QUIT
Begin DoDot:1
+2 SET AGEL(0)=^AUPNMCD(AGEL,0)
IF '$DATA(^DPT(+AGEL(0),0))
QUIT
+3 SET AGELP("MCD")=AGEL
+4 WRITE !,AGEL("I")+12,") ",$PIECE(^DPT(+AGEL(0),0),U)
+5 IF $DATA(DUZ(2))
IF $DATA(^AUPNPAT(AGEL(0),41,DUZ(2),0))
WRITE ?35,$PIECE(^(0),U,2)
+6 SET AGELP(+AGEL(0))=(AGEL("I")+12)_U_AGEL
+7 WRITE ?44
+8 WRITE $SELECT($PIECE(AGEL(0),U,6)]"":$PIECE(^AUTTRLSH($PIECE(AGEL(0),U,6),0),U),1:"SELF")
+9 SET (AGEL("HIT"),AGEL(1),AGEL("LAST"),AGEL("NUM"))=0
+10 FOR
SET AGEL(1)=$ORDER(^AUPNMCD(AGEL,11,AGEL(1)))
IF '+AGEL(1)
QUIT
SET AGEL(10)=^(AGEL(1),0)
Begin DoDot:2
+11 IF $PIECE(AGEL(10),U,2)=""
SET AGEL("HIT")=1
SET AGEL("NUM")=AGEL(1)
QUIT
+12 IF $PIECE(AGEL(10),U,2)>AGEL("LAST")
Begin DoDot:3
+13 SET AGEL("LAST")=$PIECE(AGEL(10),U,2)
SET AGEL("NUM")=AGEL(1)
End DoDot:3
End DoDot:2
IF AGEL("HIT")
QUIT
+14 IF AGEL("NUM")
Begin DoDot:2
+15 SET AGEL("DT")=$PIECE(^AUPNMCD(AGEL,11,AGEL("NUM"),0),U)
+16 SET $PIECE(AGELP(+AGEL(0)),U,3)=AGEL("DT")
+17 DO DT
+18 WRITE ?62,AGEL("DT")
+19 IF $PIECE(^AUPNMCD(AGEL,11,AGEL("NUM"),0),U,2)]""
SET AGEL("DT")=$PIECE(^AUPNMCD(AGEL,11,AGEL("NUM"),0),U,2)
DO DT
WRITE ?71,"/",AGEL("DT")
End DoDot:2
End DoDot:1
+20 QUIT
PRVT SET AGEL=""
+1 FOR AGEL("I")=1:1
SET AGEL=$ORDER(^AUPNPRVT("C",AGELP("PH"),AGEL))
IF '+AGEL
QUIT
SET AGEL(1)=$ORDER(^(AGEL,""))
Begin DoDot:1
+2 IF '$DATA(^AUPNPRVT(AGEL,0))
KILL ^AUPNPRVT("C",AGELP("PH"),AGEL)
QUIT
+3 SET AGEL(0)=$GET(^AUPNPRVT(AGEL,0))
+4 SET AGEL(10)=$GET(^AUPNPRVT(AGEL,11,AGEL(1),0))
+5 SET AGEL(2)=$GET(^AUPNPRVT(AGEL,11,AGEL(1),2))
+6 SET AGELP("PI")=AGEL
+7 ;# and member name
+8 WRITE !,AGEL("I")+12,") "
+9 IF $PIECE(AGEL(0),U)'=""
WRITE $EXTRACT($PIECE($GET(^DPT($PIECE(AGEL(0),U),0)),U),1,17)
+10 ;new person code
+11 IF $PIECE(AGEL(10),U,12)]""
WRITE ?22,$PIECE(AGEL(10),U,12)
+12 ;member #
+13 IF $PIECE($GET(AGEL(2)),U)=""
IF ($GET(AGEL)=$GET(AGELP("PHPAT")))
Begin DoDot:2
+14 SET DIE="^AUPNPRVT("_AGEL_",11,"
+15 SET DA=AGEL(1)
+16 SET DR="21////"_$PIECE($GET(^AUPN3PPH(AGELP("PH"),0)),U,4)
+17 DO ^DIE
+18 SET AGEL(2)=$GET(^AUPNPRVT(AGEL,11,AGEL(1),2))
End DoDot:2
+19 IF $PIECE(AGEL(2),U)]""
WRITE ?26,$EXTRACT($PIECE(AGEL(2),U),1,13)
+20 ;hrn
+21 IF $DATA(DUZ(2))
IF $DATA(^AUPNPAT(AGEL(0),41,DUZ(2),0))
Begin DoDot:2
+22 WRITE ?42,$PIECE(^AUPNPAT(AGEL(0),41,DUZ(2),0),U,2)
End DoDot:2
+23 SET AGELP(+AGEL(0))=(AGEL("I")+12)_U_AGEL(1)
+24 ;relationship
+25 WRITE ?50
+26 SET AGREL=$PIECE(AGEL(10),U,5)
+27 IF AGREL'=""
Begin DoDot:2
+28 SET AGREL=$SELECT($PIECE($GET(^AUTTRLSH(AGREL,0)),U)'="":$PIECE(^AUTTRLSH(AGREL,0),U),1:"SELF")
End DoDot:2
+29 IF '$TEST
SET AGREL=""
+30 WRITE $EXTRACT(AGREL,1,9)
+31 ;from/thru
+32 SET AGEL("DT")=$PIECE(AGEL(10),U,6)
+33 DO DT
+34 WRITE ?60,AGEL("DT")
+35 SET AGEL("DT")=$PIECE(AGEL(10),U,7)
+36 DO DT
+37 IF AGEL("DT")]""
WRITE "-",AGEL("DT")
End DoDot:1
+38 QUIT
DT ;
+1 IF AGEL("DT")]""
SET AGEL("DT")=$$FMTE^XLFDT(AGEL("DT"),5)
+2 QUIT
