AGEDTPL ; IHS/ASDS/TPF - THIRD PARTY LIABILITY ;
;;7.1;PATIENT REGISTRATION;**1,2,9**;AUG 25, 2005
;A NEW THIRD PART LIABILITY DISPLAY PAGE. REPLACES AGED4B WHICH IS
;OBSOLETE
;AG*7.1*9 - CHANGES TO CODE TO ADD CLAIM INFORMATION SECTION
;
EN(AD0,AD1,NEWENTRY,AGSELECT,AGELPINS) ;EP
;IF ITS A NEW ENTRY THEN DISP THE SCREEN, MSG, AND AUTOMATICALLY
;ENTER A NEW PATIENT RECORD THEN ASK FOR THE DATE OF INJURY
K TPLDEL
I NEWENTRY D Q:EXIT
.S EXIT=0
.D DRAW,AMSG,NEWENTRY I +$G(Y)<0 S EXIT=1 W !,"Entry not made." D CLEAN(AD0) H 2 D END Q
.D DESCAI
.D CAUSE
.D RESPNAM
.D RESPSSN
.D RESPINS
.D POLEFF
.D POLEND
.D GRPNAME
.D POLNO
.D APATATTY
.D CLM
.D DTLWRK
.D DTSDIS
.D DTEDIS
.D DTRWRK
.D CNTINF
.D NOTES
.S COMPIEN=AD0_",1,"_AD1
.;S AGSELECT=$$UPDTSEL^AGUTILS("FINDTPL",.AGINS,COMPIEN)
.S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGELP("INS")) ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
.S NEWENTRY=0
S COMPIEN=AD0_",1,"_AD1
VAR D DRAW
Q:$D(AGSEENLY)
W !,AGLINE("EQ")
K DIR
S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
D READ^AGED1
;CHECK TO SEE IF THERE ARE ANY DATE ENTRIES LEFT. IF NOT, CLEAR
;THE REMAINING TOP LEVEL RECORD SINCE NOTHING REALLY EXISTS FOR
;THIS PATIENT ANYMORE
I Y="",'$O(^AUPNTPL(AD0,1,0)) D CLEAN(AD0) Q
I Y[(",") G CONT
I $D(MYERRS("C","E")),(Y'?1N.N),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR
Q:Y=AGOPT("ESCAPE")
G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
Q:$D(DFOUT)!$D(DTOUT)
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
CONT ;DATE OF INJURY; DESC OF INJURY; CAUSE OF INJURY; RESPONSIBLE
;PARTY NAME; RESPONSIBLE PARTY SSN; RESPONSIBLE INSURANCE COMPANY;
;POLICY EFF DATE; POLICY END DATE; GROUP NAME; GROUP #;
;POLICY #; PATIENT'S ATTORNEY; NOTES
S AG("C")="DTACC,DESCAI,CAUSE,RESPNAM,RESPSSN,RESPINS,POLEFF,POLEND,GRPNAME,POLNO,APATATTY,CLM,DTLWRK,DTSDIS,DTEDIS,DTRWRK,CNTINF,NOTES"
S AGY=Y
F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N")) D @($P(AG("C"),",",AG("SEL")))
;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS
;CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
I $G(TPLDEL) Q
;S AGSELECT=$$UPDTSEL^AGUTILS("FINDTPL",.AGINS,COMPIEN)
S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2)) ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
D UPDATE1^AGED(DUZ(2),DFN,3,"")
K AGI,AGY
G VAR
CLEAN(AD0) ;EP - CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN
;ENTERED. IF NOT, CLEAR THE REMAINING TOP LEVEL RECORD SINCE
;NOTHING REALLY EXISTS IN THIS RECORD
I '$O(^AUPNTPL(AD0,1,0)) D CLEANZER(AD0)
Q
CLEANZER(AD0) ;EP - CLEAN ZERO NODE WITH NO DATES
K DIK,DA
S DIK="^AUPNTPL(",DA=AD0 D ^DIK
Q
END K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT
K ADFN,WDFN,REC,ROUTID,TPLDEL,COMPIEN
Q
DRAW ;EP
S AG("PG")="4TPLA"
S ROUTID=$P($T(+1)," ")
S SEQHD="THIRD PARTY LIABILITY"
D ^AGED
K ^UTILITY("DIQ1",$J)
W ?30,"THIRD PARTY LIABILITY"
W !,AGLINE("-")
D GETAW
Q
GETAW ;DISPLAY
F AG=1:1 D Q:$G(AGSCRN)[("*END*")
. S AGSCRN=$P($T(@1+AG),";;",2,14)
. Q:AGSCRN[("*END*")
. I AG=4 W !,"-RESPONSIBLE PARTY--------------------------------------------------------------"
. I AG=7 W !,"-COVERAGE DATA------------------------------------------------------------------"
. I AG=12 W !,"-CLAIM INFORMATION--------------------------------------------------------------"
. I AG=18 W !,AGLINE("-")
. S CAPTION=$P(AGSCRN,U)
. S DIC=$P(AGSCRN,U,3)
. S DR=$P(AGSCRN,U,4)
. S NEWLINE=$P(AGSCRN,U,5)
. S CAPDENT=$P(AGSCRN,U,2)
.W @NEWLINE,$S(AG=2:3,AG=3:2,1:AG),".",@CAPDENT,$S($G(CAPTION)'="":CAPTION,1:$P($G(^DD(DIC,DR,0)),U)),": " ;AG*7.1*9 - Removed extra space after :
.;IF EDITING DISP DATA ONLY
.;E DISP ONLY THE CAPS
.I 'NEWENTRY D
.. S D0=AD0
.. I DIC'["." S D0=D0_","
.. E S D0=AD1_","_D0_","
.. W $$GET1^DIQ(DIC,D0,DR)
.. ;I AG=2 D WRAP^AGUTILS($$GET1^DIQ(DIC,D0,DR),52,"WC10")
.. I AG=9 W ?42,"GROUP NUMBER: ",$S($$GET1^DIQ(DIC,D0,DR,"I"):$P($G(^AUTNEGRP($$GET1^DIQ(DIC,D0,DR,"I"),0)),U,2),1:"")
S AG("N")=AG-1
W !,$G(AGLINE("-"))
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="FINDTPL",MYVARS("SITE")=DUZ(2),MYVARS("SELECTION")=$G(AGSELECT)
I '$G(NEWENTRY) D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
W !,$G(AGLINE("-"))
D VERIF^AGUTILS
I $D(AGSEENLY) S DIR("A")="Press return: ",DIR(0)="FO" D ^DIR Q
Q
AMSG ;DISP THIS MSG IF THERE NO ENTRY IN THE THIRD PARTY LIABILITY
;FILE GLOBAL
W !,"You must first enter the DATE OF INJURY"
Q
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; THIRD PARTY LIABILITY FLDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
NEWENTRY ;TOTALLY NEW ENTRY
W !!
K DIC,DIE,DR,DA
S DIC="^AUPNTPL("
S DIC(0)="L"
S X="`"_DFN
K DD,DO
D ^DIC
Q:Y<0
S AD0=+Y
S NEWENTRY=0
ADDDT ;
K DIC,DIE,DR,DA
S DA(1)=AD0
S DIC="^AUPNTPL("_DA(1)_",1,"
S DIC(0)="LAE"
K DD,DO
D ^DIC
Q:Y<0
S AD1=+Y
I $G(AGELPINS)'="" D
.S DIE="^AUPNTPL("_DA(1)_",1,"
.S DA(1)=AD0
.S DR=".02////^S X=AGELPINS"
.S DA=AD1
.D ^DIE
Q
DTACC ;DATE OF INJURY
I '$D(^AUPNTPL(AD0)) D NEWENTRY Q
K DIC,DR,DIE,DA,DD,D0
S TPLDEL=0
S DA(1)=AD0
S DA=AD1
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR=".01"
D ^DIE
I '$D(DA) S TPLDEL=1
S:$G(D1)'="" AD1=D1 ;GET NEW SUBENTRY IEN
K DIC,DR,DIE
Q
DESCAI ;DESC OF INJURY
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="105"
D ^DIE
K DIC,DR,DIE,DA
Q
CAUSE ;CAUSE OF INJURY
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="104"
D ^DIE
K DIC,DR,DIE,DA
Q
RESPNAM ;RESPONSIBLE PARTY NAME
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="101"
D ^DIE
K DIC,DR,DIE,DA
Q
RESPSSN ;RESPONSIBLE PARTY SSN
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="102"
D ^DIE
K DIC,DR,DIE,DA
Q
RESPINS ;RESPONSIBLE PARTY INSURANCE COMPANY
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR=".02"
D ^DIE
K DIC,DR,DIE,DA
Q
POLEFF ;EFF DATE
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR=".04"
D ^DIE
K DIC,DR,DIE,DA
;COMPARE EFF AND END DATES
I '$$GOODDT(AD0,AD1) G POLEFF
Q
POLEND ;END DATE
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR=".05"
D ^DIE
K DIC,DR,DIE,DA
;COMPARE EFF AND END DATES
I '$$GOODDT(AD0,AD1) G POLEND
Q
GOODDT(AD0,AD1) ;EP - CHECK IF EFF AND END DATES MAKE SENSE
N BDT,EDT
S BDT=$P($G(^AUPNTPL(AD0,1,AD1,0)),U,4)
S EDT=$P($G(^AUPNTPL(AD0,1,AD1,0)),U,5)
I EDT,'BDT W !,"CANNOT HAVE AN ENDING DATE WITHOUT A BEGINNING DATE! TRY AGAIN" Q 0
I EDT<BDT&(+EDT'=0) W !,"ENDING DATE IS LESS THAN THE EFFECTIVE DATE! TRY AGAIN" Q 0
I BDT>EDT&(+EDT'=0) W !,"EFFECTIVE DATE IS GREATER THAN THE ENDING DATE! TRY AGAIN" Q 0
Q 1
;
GDDDT(AD0,AD1) ;CHECK DISABILITY START/END DATES - AG*7.1*9
N BDT,EDT
S BDT=$$GET1^DIQ(9000041.0101,AD1_","_AD0_",",203,"I") ;$P($G(^AUPNWC(WD0,1,WD1,0)),U,12)
S EDT=$$GET1^DIQ(9000041.0101,AD1_","_AD0_",",204,"I") ;$P($G(^AUPNWC(WD0,1,WD1,0)),U,13)
I EDT,'BDT W !,"CANNOT HAVE AN ENDING DATE WITHOUT A BEGINNING DATE! TRY AGAIN" Q 0
I EDT<BDT&(+EDT'=0) W !,"DISABILITY ENDING DATE IS LESS THAN THE EFFECTIVE DATE! TRY AGAIN" Q 0
I BDT>EDT&(+EDT'=0) W !,"DISABILITY START DATE IS GREATER THAN THE ENDING DATE! TRY AGAIN" Q 0
Q 1
CLM ;CLAIM # - AG*7.1*9
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="201"
D ^DIE
K DIC,DR,DIE,DA
Q
DTLWRK ;DATE LAST WORKED - AG*7.1*9
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="202"
D ^DIE
K DIC,DR,DIE,DA
Q
DTSDIS ;DISABILITY START DATE - AG*7.1*9
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="203"
D ^DIE
K DIC,DR,DIE,DA
I '$$GDDDT(AD0,AD1) G DTSDIS
Q
DTEDIS ;DISABILITY END DATE - AG*7.1*9
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="204"
D ^DIE
K DIC,DR,DIE,DA
I '$$GDDDT(AD0,AD1) G DTEDIS
Q
DTRWRK ;DATE AUTHORIZED TO WORK - AG*7.1*9
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="205"
D ^DIE
K DIC,DR,DIE,DA
Q
CNTINF ;CONTACT INFO - AG*7.1*9
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="206"
D ^DIE
K DIC,DR,DIE,DA
Q
GRPNAME ;GROUP NAME AND #
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR=".06"
D ^DIE
K DIC,DR,DIE,DA
GRPNUM ;GROUP #
Q
POLNO ;INSURANCE POLICY #
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
I $$ISREQ^AGFLDREQ(9000041,.03) S DIE("NO^")="",DR=".03R"
E S DR=".03"
D ^DIE
K DIC,DR,DIE,DA
Q
APATATTY ;NAME OF PATIENT'S ATTORNEY
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="103"
D ^DIE
K DIC,DR,DIE,DA
Q
NOTES ;NOTES
W !
K DIC,DR,DIE,DA,DD,DO
S DA=AD1
S DA(1)=AD0
S DIE="^AUPNTPL("_DA(1)_",1,"
S DR="106"
W $$NOTELINE^AGUTILS(DR,9000041.0101,AD1_","_AD0_",",45)
D ^DIE
K DIC,DR,DIE,DA
Q
; ****************************************************************
; ON LINES BELOW:
; PIECE 1= FIELD CAP
; IF THIS IS FILLED IN IT WILL BE USED AS THE CAP ON THE SCREEN
; IF IT IS NOT THEN THE FLD LBL FROM THE DD WILL BE USED
; PIECE 2= POSITION ON LINE TO DISP FLD CAP
; PIECE 3= FILE #
; PIECE 4= FLD #
; PIECE 5 - NEW LINE OR NOT
;
1 ;
;;TPL INJURY DATE^?4^9000041.0101^.01^!
;;CAUSE^?16^9000041.0101^104^?40
;;DESCRIPTION....^?4^9000041.0101^105^!
;;NAME...........^?4^9000041.0101^101^!
;;SOCIAL SECURITY NO^?49^9000041.0101^102^?46
;;INSURANCE COVERAGE^?4^9000041.0101^.02^!
;;EFFECTIVE DATE.^?4^9000041.0101^.04^!
;;ENDING DATE.^?16^9000041.0101^.05^?40
;;GROUP NAME.....^?4^9000041.0101^.06^!
;;POLICY NUMBER..^?4^9000041.0101^.03^!
;;PATIENT'S ATTORNEY^?42^9000041.0101^103^?39
;;CLAIM #^?4^9000041.0101^201^!
;;DATE LAST WORKED^?43^9000041.0101^202^?40
;;DISABILITY START DATE^?4^9000041.0101^203^!
;;DISABILITY END DATE^?44^9000041.0101^204^?40
;;DATE AUTHORIZED RETURN TO WORK^?4^9000041.0101^205^!
;;CONTACT INFO^?4^9000041.0101^206^!
;;NOTES^?4^9000041.0101^106^!
;;*END*
AGEDTPL ; IHS/ASDS/TPF - THIRD PARTY LIABILITY ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,9**;AUG 25, 2005
+2 ;A NEW THIRD PART LIABILITY DISPLAY PAGE. REPLACES AGED4B WHICH IS
+3 ;OBSOLETE
+4 ;AG*7.1*9 - CHANGES TO CODE TO ADD CLAIM INFORMATION SECTION
+5 ;
EN(AD0,AD1,NEWENTRY,AGSELECT,AGELPINS) ;EP
+1 ;IF ITS A NEW ENTRY THEN DISP THE SCREEN, MSG, AND AUTOMATICALLY
+2 ;ENTER A NEW PATIENT RECORD THEN ASK FOR THE DATE OF INJURY
+3 KILL TPLDEL
+4 IF NEWENTRY
Begin DoDot:1
+5 SET EXIT=0
+6 DO DRAW
DO AMSG
DO NEWENTRY
IF +$GET(Y)<0
SET EXIT=1
WRITE !,"Entry not made."
DO CLEAN(AD0)
HANG 2
DO END
QUIT
+7 DO DESCAI
+8 DO CAUSE
+9 DO RESPNAM
+10 DO RESPSSN
+11 DO RESPINS
+12 DO POLEFF
+13 DO POLEND
+14 DO GRPNAME
+15 DO POLNO
+16 DO APATATTY
+17 DO CLM
+18 DO DTLWRK
+19 DO DTSDIS
+20 DO DTEDIS
+21 DO DTRWRK
+22 DO CNTINF
+23 DO NOTES
+24 SET COMPIEN=AD0_",1,"_AD1
+25 ;S AGSELECT=$$UPDTSEL^AGUTILS("FINDTPL",.AGINS,COMPIEN)
+26 ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGELP("INS"))
+27 SET NEWENTRY=0
End DoDot:1
IF EXIT
QUIT
+28 SET COMPIEN=AD0_",1,"_AD1
VAR DO DRAW
+1 IF $DATA(AGSEENLY)
QUIT
+2 WRITE !,AGLINE("EQ")
+3 KILL DIR
+4 SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
+5 DO READ^AGED1
+6 ;CHECK TO SEE IF THERE ARE ANY DATE ENTRIES LEFT. IF NOT, CLEAR
+7 ;THE REMAINING TOP LEVEL RECORD SINCE NOTHING REALLY EXISTS FOR
+8 ;THIS PATIENT ANYMORE
+9 IF Y=""
IF '$ORDER(^AUPNTPL(AD0,1,0))
DO CLEAN(AD0)
QUIT
+10 IF Y[(",")
GOTO CONT
+11 IF $DATA(MYERRS("C","E"))
IF (Y'?1N.N)
IF (Y'=AGOPT("ESCAPE"))
WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"
HANG 3
GOTO VAR
+12 IF Y=AGOPT("ESCAPE")
QUIT
+13 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+14 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
+15 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
GOTO VAR
CONT ;DATE OF INJURY; DESC OF INJURY; CAUSE OF INJURY; RESPONSIBLE
+1 ;PARTY NAME; RESPONSIBLE PARTY SSN; RESPONSIBLE INSURANCE COMPANY;
+2 ;POLICY EFF DATE; POLICY END DATE; GROUP NAME; GROUP #;
+3 ;POLICY #; PATIENT'S ATTORNEY; NOTES
+4 SET AG("C")="DTACC,DESCAI,CAUSE,RESPNAM,RESPSSN,RESPINS,POLEFF,POLEND,GRPNAME,POLNO,APATATTY,CLM,DTLWRK,DTSDIS,DTEDIS,DTRWRK,CNTINF,NOTES"
+5 SET AGY=Y
+6 FOR AGI=1:1
SET AG("SEL")=+$PIECE(AGY,",",AGI)
IF AG("SEL")<1!(AG("SEL")>AG("N"))
QUIT
DO @($PIECE(AG("C"),",",AG("SEL")))
+7 ;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS
+8 ;CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
+9 IF $GET(TPLDEL)
QUIT
+10 ;S AGSELECT=$$UPDTSEL^AGUTILS("FINDTPL",.AGINS,COMPIEN)
+11 ;AG*7.1*1 IM18549 ERROR IN ERROR UPDATE
SET AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$PIECE(AGSELECT,U,2))
+12 DO UPDATE1^AGED(DUZ(2),DFN,3,"")
+13 KILL AGI,AGY
+14 GOTO VAR
CLEAN(AD0) ;EP - CHECK HERE TO SEE IF ENTRIES HAVE ACTUALLY BEEN
+1 ;ENTERED. IF NOT, CLEAR THE REMAINING TOP LEVEL RECORD SINCE
+2 ;NOTHING REALLY EXISTS IN THIS RECORD
+3 IF '$ORDER(^AUPNTPL(AD0,1,0))
DO CLEANZER(AD0)
+4 QUIT
CLEANZER(AD0) ;EP - CLEAN ZERO NODE WITH NO DATES
+1 KILL DIK,DA
+2 SET DIK="^AUPNTPL("
SET DA=AD0
DO ^DIK
+3 QUIT
END KILL AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT
+1 KILL ADFN,WDFN,REC,ROUTID,TPLDEL,COMPIEN
+2 QUIT
DRAW ;EP
+1 SET AG("PG")="4TPLA"
+2 SET ROUTID=$PIECE($TEXT(+1)," ")
+3 SET SEQHD="THIRD PARTY LIABILITY"
+4 DO ^AGED
+5 KILL ^UTILITY("DIQ1",$JOB)
+6 WRITE ?30,"THIRD PARTY LIABILITY"
+7 WRITE !,AGLINE("-")
+8 DO GETAW
+9 QUIT
GETAW ;DISPLAY
+1 FOR AG=1:1
Begin DoDot:1
+2 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,14)
+3 IF AGSCRN[("*END*")
QUIT
+4 IF AG=4
WRITE !,"-RESPONSIBLE PARTY--------------------------------------------------------------"
+5 IF AG=7
WRITE !,"-COVERAGE DATA------------------------------------------------------------------"
+6 IF AG=12
WRITE !,"-CLAIM INFORMATION--------------------------------------------------------------"
+7 IF AG=18
WRITE !,AGLINE("-")
+8 SET CAPTION=$PIECE(AGSCRN,U)
+9 SET DIC=$PIECE(AGSCRN,U,3)
+10 SET DR=$PIECE(AGSCRN,U,4)
+11 SET NEWLINE=$PIECE(AGSCRN,U,5)
+12 SET CAPDENT=$PIECE(AGSCRN,U,2)
+13 ;AG*7.1*9 - Removed extra space after :
WRITE @NEWLINE,$SELECT(AG=2:3,AG=3:2,1:AG),".",@CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION,1:$PIECE($GET(^DD(DIC,DR,0)),U)),": "
+14 ;IF EDITING DISP DATA ONLY
+15 ;E DISP ONLY THE CAPS
+16 IF 'NEWENTRY
Begin DoDot:2
+17 SET D0=AD0
+18 IF DIC'["."
SET D0=D0_","
+19 IF '$TEST
SET D0=AD1_","_D0_","
+20 WRITE $$GET1^DIQ(DIC,D0,DR)
+21 ;I AG=2 D WRAP^AGUTILS($$GET1^DIQ(DIC,D0,DR),52,"WC10")
+22 IF AG=9
WRITE ?42,"GROUP NUMBER: ",$SELECT($$GET1^DIQ(DIC,D0,DR,"I"):$PIECE($GET(^AUTNEGRP($$GET1^DIQ(DIC,D0,DR,"I"),0)),U,2),1:"")
End DoDot:2
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+23 SET AG("N")=AG-1
+24 WRITE !,$GET(AGLINE("-"))
+25 KILL MYERRS,MYVARS
+26 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+27 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")="FINDTPL"
SET MYVARS("SITE")=DUZ(2)
SET MYVARS("SELECTION")=$GET(AGSELECT)
+28 IF '$GET(NEWENTRY)
DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+29 WRITE !,$GET(AGLINE("-"))
+30 DO VERIF^AGUTILS
+31 IF $DATA(AGSEENLY)
SET DIR("A")="Press return: "
SET DIR(0)="FO"
DO ^DIR
QUIT
+32 QUIT
AMSG ;DISP THIS MSG IF THERE NO ENTRY IN THE THIRD PARTY LIABILITY
+1 ;FILE GLOBAL
+2 WRITE !,"You must first enter the DATE OF INJURY"
+3 QUIT
+4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+5 ; THIRD PARTY LIABILITY FLDS
+6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
NEWENTRY ;TOTALLY NEW ENTRY
+1 WRITE !!
+2 KILL DIC,DIE,DR,DA
+3 SET DIC="^AUPNTPL("
+4 SET DIC(0)="L"
+5 SET X="`"_DFN
+6 KILL DD,DO
+7 DO ^DIC
+8 IF Y<0
QUIT
+9 SET AD0=+Y
+10 SET NEWENTRY=0
ADDDT ;
+1 KILL DIC,DIE,DR,DA
+2 SET DA(1)=AD0
+3 SET DIC="^AUPNTPL("_DA(1)_",1,"
+4 SET DIC(0)="LAE"
+5 KILL DD,DO
+6 DO ^DIC
+7 IF Y<0
QUIT
+8 SET AD1=+Y
+9 IF $GET(AGELPINS)'=""
Begin DoDot:1
+10 SET DIE="^AUPNTPL("_DA(1)_",1,"
+11 SET DA(1)=AD0
+12 SET DR=".02////^S X=AGELPINS"
+13 SET DA=AD1
+14 DO ^DIE
End DoDot:1
+15 QUIT
DTACC ;DATE OF INJURY
+1 IF '$DATA(^AUPNTPL(AD0))
DO NEWENTRY
QUIT
+2 KILL DIC,DR,DIE,DA,DD,D0
+3 SET TPLDEL=0
+4 SET DA(1)=AD0
+5 SET DA=AD1
+6 SET DIE="^AUPNTPL("_DA(1)_",1,"
+7 SET DR=".01"
+8 DO ^DIE
+9 IF '$DATA(DA)
SET TPLDEL=1
+10 ;GET NEW SUBENTRY IEN
IF $GET(D1)'=""
SET AD1=D1
+11 KILL DIC,DR,DIE
+12 QUIT
DESCAI ;DESC OF INJURY
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="105"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
CAUSE ;CAUSE OF INJURY
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="104"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
RESPNAM ;RESPONSIBLE PARTY NAME
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="101"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
RESPSSN ;RESPONSIBLE PARTY SSN
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="102"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
RESPINS ;RESPONSIBLE PARTY INSURANCE COMPANY
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR=".02"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
POLEFF ;EFF DATE
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR=".04"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 ;COMPARE EFF AND END DATES
+10 IF '$$GOODDT(AD0,AD1)
GOTO POLEFF
+11 QUIT
POLEND ;END DATE
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR=".05"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 ;COMPARE EFF AND END DATES
+10 IF '$$GOODDT(AD0,AD1)
GOTO POLEND
+11 QUIT
GOODDT(AD0,AD1) ;EP - CHECK IF EFF AND END DATES MAKE SENSE
+1 NEW BDT,EDT
+2 SET BDT=$PIECE($GET(^AUPNTPL(AD0,1,AD1,0)),U,4)
+3 SET EDT=$PIECE($GET(^AUPNTPL(AD0,1,AD1,0)),U,5)
+4 IF EDT
IF 'BDT
WRITE !,"CANNOT HAVE AN ENDING DATE WITHOUT A BEGINNING DATE! TRY AGAIN"
QUIT 0
+5 IF EDT<BDT&(+EDT'=0)
WRITE !,"ENDING DATE IS LESS THAN THE EFFECTIVE DATE! TRY AGAIN"
QUIT 0
+6 IF BDT>EDT&(+EDT'=0)
WRITE !,"EFFECTIVE DATE IS GREATER THAN THE ENDING DATE! TRY AGAIN"
QUIT 0
+7 QUIT 1
+8 ;
GDDDT(AD0,AD1) ;CHECK DISABILITY START/END DATES - AG*7.1*9
+1 NEW BDT,EDT
+2 ;$P($G(^AUPNWC(WD0,1,WD1,0)),U,12)
SET BDT=$$GET1^DIQ(9000041.0101,AD1_","_AD0_",",203,"I")
+3 ;$P($G(^AUPNWC(WD0,1,WD1,0)),U,13)
SET EDT=$$GET1^DIQ(9000041.0101,AD1_","_AD0_",",204,"I")
+4 IF EDT
IF 'BDT
WRITE !,"CANNOT HAVE AN ENDING DATE WITHOUT A BEGINNING DATE! TRY AGAIN"
QUIT 0
+5 IF EDT<BDT&(+EDT'=0)
WRITE !,"DISABILITY ENDING DATE IS LESS THAN THE EFFECTIVE DATE! TRY AGAIN"
QUIT 0
+6 IF BDT>EDT&(+EDT'=0)
WRITE !,"DISABILITY START DATE IS GREATER THAN THE ENDING DATE! TRY AGAIN"
QUIT 0
+7 QUIT 1
CLM ;CLAIM # - AG*7.1*9
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="201"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
DTLWRK ;DATE LAST WORKED - AG*7.1*9
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="202"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
DTSDIS ;DISABILITY START DATE - AG*7.1*9
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="203"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 IF '$$GDDDT(AD0,AD1)
GOTO DTSDIS
+10 QUIT
DTEDIS ;DISABILITY END DATE - AG*7.1*9
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="204"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 IF '$$GDDDT(AD0,AD1)
GOTO DTEDIS
+10 QUIT
DTRWRK ;DATE AUTHORIZED TO WORK - AG*7.1*9
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="205"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
CNTINF ;CONTACT INFO - AG*7.1*9
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="206"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
GRPNAME ;GROUP NAME AND #
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR=".06"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
GRPNUM ;GROUP #
+1 QUIT
POLNO ;INSURANCE POLICY #
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 IF $$ISREQ^AGFLDREQ(9000041,.03)
SET DIE("NO^")=""
SET DR=".03R"
+7 IF '$TEST
SET DR=".03"
+8 DO ^DIE
+9 KILL DIC,DR,DIE,DA
+10 QUIT
APATATTY ;NAME OF PATIENT'S ATTORNEY
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="103"
+7 DO ^DIE
+8 KILL DIC,DR,DIE,DA
+9 QUIT
NOTES ;NOTES
+1 WRITE !
+2 KILL DIC,DR,DIE,DA,DD,DO
+3 SET DA=AD1
+4 SET DA(1)=AD0
+5 SET DIE="^AUPNTPL("_DA(1)_",1,"
+6 SET DR="106"
+7 WRITE $$NOTELINE^AGUTILS(DR,9000041.0101,AD1_","_AD0_",",45)
+8 DO ^DIE
+9 KILL DIC,DR,DIE,DA
+10 QUIT
+11 ; ****************************************************************
+12 ; ON LINES BELOW:
+13 ; PIECE 1= FIELD CAP
+14 ; IF THIS IS FILLED IN IT WILL BE USED AS THE CAP ON THE SCREEN
+15 ; IF IT IS NOT THEN THE FLD LBL FROM THE DD WILL BE USED
+16 ; PIECE 2= POSITION ON LINE TO DISP FLD CAP
+17 ; PIECE 3= FILE #
+18 ; PIECE 4= FLD #
+19 ; PIECE 5 - NEW LINE OR NOT
+20 ;
1 ;
+1 ;;TPL INJURY DATE^?4^9000041.0101^.01^!
+2 ;;CAUSE^?16^9000041.0101^104^?40
+3 ;;DESCRIPTION....^?4^9000041.0101^105^!
+4 ;;NAME...........^?4^9000041.0101^101^!
+5 ;;SOCIAL SECURITY NO^?49^9000041.0101^102^?46
+6 ;;INSURANCE COVERAGE^?4^9000041.0101^.02^!
+7 ;;EFFECTIVE DATE.^?4^9000041.0101^.04^!
+8 ;;ENDING DATE.^?16^9000041.0101^.05^?40
+9 ;;GROUP NAME.....^?4^9000041.0101^.06^!
+10 ;;POLICY NUMBER..^?4^9000041.0101^.03^!
+11 ;;PATIENT'S ATTORNEY^?42^9000041.0101^103^?39
+12 ;;CLAIM #^?4^9000041.0101^201^!
+13 ;;DATE LAST WORKED^?43^9000041.0101^202^?40
+14 ;;DISABILITY START DATE^?4^9000041.0101^203^!
+15 ;;DISABILITY END DATE^?44^9000041.0101^204^?40
+16 ;;DATE AUTHORIZED RETURN TO WORK^?4^9000041.0101^205^!
+17 ;;CONTACT INFO^?4^9000041.0101^206^!
+18 ;;NOTES^?4^9000041.0101^106^!
+19 ;;*END*
