- 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
