AGFACE7 ; IHS/ASDS/EFG - FACE SHEET (PRVT INS, VET, OTHER REG, ELIG.) ;
;;7.1;PATIENT REGISTRATION;**2,8**;AUG 25, 2005
I $D(^AUPNPRVT(DFN,0)) D
.I $Y+6>IOSL D HDR^AGFACE Q:$D(AGQUIT)
.W !,$G(AG("-")),!,"PRIVATE INSURANCE:",!,"INS. COMPANY",?29,"NUMBER",?46,"ELIG. DATE",?60,"ELIG. END DATE"
.S DIC=9000006.11,DR=.01,DA=DFN S AG=0 F S AG=$O(^AUPNPRVT(DFN,11,AG)) Q:'AG S AGL=$G(^AUPNPRVT(DFN,11,AG,0)) D PVT
Q:$D(AGQUIT)
I $D(^DPT(DFN,"VET")),^("VET")="Y" D VET
S DIC=9000001.41,DR=.01,DA=DFN,AG(1)=""
N I S I=0,AG(1)="" F S I=$O(^AUPNPAT(DFN,41,I)) Q:'I D Q:$D(AGQUIT)
.Q:I=DUZ(2)
.I $Y+6>IOSL D HDR^AGFACE Q:$D(AGQUIT)
.Q:$D(AGQUIT)
.W:$D(AG(1)) !,$G(AG("-")),!,"THE PATIENT IS ALSO REGISTERED AT:"
.W !,$P($G(^DIC(4,I,0)),U),?40,"CHART #: ",$P($G(^AUPNPAT(DFN,41,I,0)),U,2)
.K AG(1)
Q:$D(AGQUIT)
EMP ;PATIENT'S EMPLOYER
S AGEMPIEN=$P($G(^AUPNPAT(DFN,0)),U,19) I AGEMPIEN]"" D
.I $Y+6>IOSL D HDR^AGFACE Q:$D(AGQUIT)
.S AG(0)=$G(^AUTNEMPL(AGEMPIEN,0)) I AG(0)="" Q
.N I F I=1:1:6 S AG(I)=$P(AG(0),U,I)
.W !,$G(AG("-")),!,"PATIENT'S EMPLOYER: ",AG(1)
.F I=2,3 W:AG(I)]"" !?20,AG(I)
.W:AG(4)]"" ", ",$P($G(^DIC(5,+AG(4),0)),U,2)
.W:AG(5)]"" " ",AG(5)
.W:AG(6)]"" !!?13,"PHONE: ",AG(6)
Q:$D(AGQUIT)
K AGEMPIEN
SPEMP ;SPOUSE'S EMPLOYER
S AGEMPIEN=$P($G(^AUPNPAT(DFN,0)),U,22) I AGEMPIEN]"" D
.I $Y+6>IOSL D HDR^AGFACE Q:$D(AGQUIT)
.S AG(0)=$G(^AUTNEMPL(AGEMPIEN,0)) I AG(0)="" Q
.N I F I=1:1:6 S AG(I)=$P(AG(0),U,I)
.W !,AG("-"),!,"SPOUSE'S EMPLOYER: ",AG(1)
.F I=2,3 W:AG(I)]"" !?20,AG(I)
.W:AG(4)]"" ", ",$P($G(^DIC(5,+AG(4),0)),U,2)
.W:AG(5)]"" " ",AG(5)
.W:AG(6)]"" !!?13,"PHONE: ",AG(6)
Q:$D(AGQUIT)
K AGEMPIEN
ELIG ;ELIGIBILITY FOR CARE
K AG("DRENT") S DIC=9000001,DA=DFN,DR=$S(AGOPT(14)="Y":1124,1:1112) D ^AGDICLK I '$D(AG("LKERR")) W !,AG("-"),! K ^TMP($J,"W") S X="*** ELIGIBILITY FOR CARE: "_AG("LKPRINT")_" ***",DIWL=5,DIWR=75,DIWF="W" D ^DIWP,^DIWW
K DIWF,DIWL,DIWR
Q
PVT ;I $P(AGL,U)]"",$D(^AUTNINS($P(AGL,U),0)) Q:(($P(AGL,U,7)]"")&(+$P(AGL,U,7)<DT)) W !,$E($P(^AUTNINS($P(AGL,U),0),U),1,29),?29,$E($P(AGL,U,2),1,26),?46 S Y=$P(AGL,U,6) D DD^%DT W Y S Y=$P(AGL,U,7) D DD^%DT W ?60,Y
;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20635
I $P(AGL,U)]"",$D(^AUTNINS($P(AGL,U),0)) Q:(($P(AGL,U,7)]"")&(+$P(AGL,U,7)<DT)) D
.W !,$E($P(^AUTNINS($P(AGL,U),0),U),1,29)
.N AGPH
.S AGPH=$P($G(^AUPNPRVT(DFN,11,AG,2)),U)
.I AGPH]"" W ?29,AGPH
.I AGPH="" D ;AG*7.1*8
..S AGPH=$P($G(^AUPNPRVT(DFN,11,AG,0)),U,8)
..I AGPH]"" W ?29,$P($G(^AUPN3PPH(AGPH,0)),U,4)
.W ?46 S Y=$P(AGL,U,6) D DD^%DT W Y S Y=$P(AGL,U,7) D DD^%DT W ?60,Y
Q
VET ;VETERAN
I $Y+6>IOSL D HDR^AGFACE Q:$D(AGQUIT)
W !,AG("-")
K ^UTILITY("DIQ1",$J)
K DIC,DIE,DIR,DIQ,DR
S DIC=2,DA=DFN,AGSCRN=$P($T(@1),";;",2)
F AG=2,3,4,6,7 D
.S X=$P(AGSCRN,";",AG),DR=$P(X,U,4)
.W !," ",?$P(X,U,2),$P(^DD(2,DR,0),U)," : "
.D EN^DIQ1
.W $G(^UTILITY("DIQ1",$J,2,DA,DR))
.K ^UTILITY("DIQ1",$J)
K ^UTILITY("DIQ1",$J),DR,AGSCRN,X
K DIC,DIE,DIR,DIQ,DR
Q
1 ;;^20^^1901;^13^^.325;^9^^.326;^4^^.327;^8^^.32101;^16^^.301;^22^^.313
AGFACE7 ; IHS/ASDS/EFG - FACE SHEET (PRVT INS, VET, OTHER REG, ELIG.) ;
+1 ;;7.1;PATIENT REGISTRATION;**2,8**;AUG 25, 2005
+2 IF $DATA(^AUPNPRVT(DFN,0))
Begin DoDot:1
+3 IF $Y+6>IOSL
DO HDR^AGFACE
IF $DATA(AGQUIT)
QUIT
+4 WRITE !,$GET(AG("-")),!,"PRIVATE INSURANCE:",!,"INS. COMPANY",?29,"NUMBER",?46,"ELIG. DATE",?60,"ELIG. END DATE"
+5 SET DIC=9000006.11
SET DR=.01
SET DA=DFN
SET AG=0
FOR
SET AG=$ORDER(^AUPNPRVT(DFN,11,AG))
IF 'AG
QUIT
SET AGL=$GET(^AUPNPRVT(DFN,11,AG,0))
DO PVT
End DoDot:1
+6 IF $DATA(AGQUIT)
QUIT
+7 IF $DATA(^DPT(DFN,"VET"))
IF ^("VET")="Y"
DO VET
+8 SET DIC=9000001.41
SET DR=.01
SET DA=DFN
SET AG(1)=""
+9 NEW I
SET I=0
SET AG(1)=""
FOR
SET I=$ORDER(^AUPNPAT(DFN,41,I))
IF 'I
QUIT
Begin DoDot:1
+10 IF I=DUZ(2)
QUIT
+11 IF $Y+6>IOSL
DO HDR^AGFACE
IF $DATA(AGQUIT)
QUIT
+12 IF $DATA(AGQUIT)
QUIT
+13 IF $DATA(AG(1))
WRITE !,$GET(AG("-")),!,"THE PATIENT IS ALSO REGISTERED AT:"
+14 WRITE !,$PIECE($GET(^DIC(4,I,0)),U),?40,"CHART #: ",$PIECE($GET(^AUPNPAT(DFN,41,I,0)),U,2)
+15 KILL AG(1)
End DoDot:1
IF $DATA(AGQUIT)
QUIT
+16 IF $DATA(AGQUIT)
QUIT
EMP ;PATIENT'S EMPLOYER
+1 SET AGEMPIEN=$PIECE($GET(^AUPNPAT(DFN,0)),U,19)
IF AGEMPIEN]""
Begin DoDot:1
+2 IF $Y+6>IOSL
DO HDR^AGFACE
IF $DATA(AGQUIT)
QUIT
+3 SET AG(0)=$GET(^AUTNEMPL(AGEMPIEN,0))
IF AG(0)=""
QUIT
+4 NEW I
FOR I=1:1:6
SET AG(I)=$PIECE(AG(0),U,I)
+5 WRITE !,$GET(AG("-")),!,"PATIENT'S EMPLOYER: ",AG(1)
+6 FOR I=2,3
IF AG(I)]""
WRITE !?20,AG(I)
+7 IF AG(4)]""
WRITE ", ",$PIECE($GET(^DIC(5,+AG(4),0)),U,2)
+8 IF AG(5)]""
WRITE " ",AG(5)
+9 IF AG(6)]""
WRITE !!?13,"PHONE: ",AG(6)
End DoDot:1
+10 IF $DATA(AGQUIT)
QUIT
+11 KILL AGEMPIEN
SPEMP ;SPOUSE'S EMPLOYER
+1 SET AGEMPIEN=$PIECE($GET(^AUPNPAT(DFN,0)),U,22)
IF AGEMPIEN]""
Begin DoDot:1
+2 IF $Y+6>IOSL
DO HDR^AGFACE
IF $DATA(AGQUIT)
QUIT
+3 SET AG(0)=$GET(^AUTNEMPL(AGEMPIEN,0))
IF AG(0)=""
QUIT
+4 NEW I
FOR I=1:1:6
SET AG(I)=$PIECE(AG(0),U,I)
+5 WRITE !,AG("-"),!,"SPOUSE'S EMPLOYER: ",AG(1)
+6 FOR I=2,3
IF AG(I)]""
WRITE !?20,AG(I)
+7 IF AG(4)]""
WRITE ", ",$PIECE($GET(^DIC(5,+AG(4),0)),U,2)
+8 IF AG(5)]""
WRITE " ",AG(5)
+9 IF AG(6)]""
WRITE !!?13,"PHONE: ",AG(6)
End DoDot:1
+10 IF $DATA(AGQUIT)
QUIT
+11 KILL AGEMPIEN
ELIG ;ELIGIBILITY FOR CARE
+1 KILL AG("DRENT")
SET DIC=9000001
SET DA=DFN
SET DR=$SELECT(AGOPT(14)="Y":1124,1:1112)
DO ^AGDICLK
IF '$DATA(AG("LKERR"))
WRITE !,AG("-"),!
KILL ^TMP($JOB,"W")
SET X="*** ELIGIBILITY FOR CARE: "_AG("LKPRINT")_" ***"
SET DIWL=5
SET DIWR=75
SET DIWF="W"
DO ^DIWP
DO ^DIWW
+2 KILL DIWF,DIWL,DIWR
+3 QUIT
PVT ;I $P(AGL,U)]"",$D(^AUTNINS($P(AGL,U),0)) Q:(($P(AGL,U,7)]"")&(+$P(AGL,U,7)<DT)) W !,$E($P(^AUTNINS($P(AGL,U),0),U),1,29),?29,$E($P(AGL,U,2),1,26),?46 S Y=$P(AGL,U,6) D DD^%DT W Y S Y=$P(AGL,U,7) D DD^%DT W ?60,Y
+1 ;IHS/SD/TPF 4/28/2006 AG*7.1*2 IM20635
+2 IF $PIECE(AGL,U)]""
IF $DATA(^AUTNINS($PIECE(AGL,U),0))
IF (($PIECE(AGL,U,7)]"")&(+$PIECE(AGL,U,7)<DT))
QUIT
Begin DoDot:1
+3 WRITE !,$EXTRACT($PIECE(^AUTNINS($PIECE(AGL,U),0),U),1,29)
+4 NEW AGPH
+5 SET AGPH=$PIECE($GET(^AUPNPRVT(DFN,11,AG,2)),U)
+6 IF AGPH]""
WRITE ?29,AGPH
+7 ;AG*7.1*8
IF AGPH=""
Begin DoDot:2
+8 SET AGPH=$PIECE($GET(^AUPNPRVT(DFN,11,AG,0)),U,8)
+9 IF AGPH]""
WRITE ?29,$PIECE($GET(^AUPN3PPH(AGPH,0)),U,4)
End DoDot:2
+10 WRITE ?46
SET Y=$PIECE(AGL,U,6)
DO DD^%DT
WRITE Y
SET Y=$PIECE(AGL,U,7)
DO DD^%DT
WRITE ?60,Y
End DoDot:1
+11 QUIT
VET ;VETERAN
+1 IF $Y+6>IOSL
DO HDR^AGFACE
IF $DATA(AGQUIT)
QUIT
+2 WRITE !,AG("-")
+3 KILL ^UTILITY("DIQ1",$JOB)
+4 KILL DIC,DIE,DIR,DIQ,DR
+5 SET DIC=2
SET DA=DFN
SET AGSCRN=$PIECE($TEXT(@1),";;",2)
+6 FOR AG=2,3,4,6,7
Begin DoDot:1
+7 SET X=$PIECE(AGSCRN,";",AG)
SET DR=$PIECE(X,U,4)
+8 WRITE !," ",?$PIECE(X,U,2),$PIECE(^DD(2,DR,0),U)," : "
+9 DO EN^DIQ1
+10 WRITE $GET(^UTILITY("DIQ1",$JOB,2,DA,DR))
+11 KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
+12 KILL ^UTILITY("DIQ1",$JOB),DR,AGSCRN,X
+13 KILL DIC,DIE,DIR,DIQ,DR
+14 QUIT
1 ;;^20^^1901;^13^^.325;^9^^.326;^4^^.327;^8^^.32101;^16^^.301;^22^^.313
