- 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
