AGEDPRVB ; IHS/ASDS/TPF - EDIT/DISPLAY PRIVATE PAGE B SCREEN ;
;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
;
EN(ID0,ID1,NEWENTRY,AGINSREC,AGINSPTR,POLHPTR,COVPTR) ;EP - CALLED BY AGED4A
S AG("PG")="4PVTB"
S AGSELECT=$G(AGINSREC)
VAR D DRAW
I $D(AGSEENLY) K DIR S DIR(0)="E",DIR("A")="Enter Response" D ^DIR Q
Q:$D(AGSEENLY)
W !,AGLINE("EQ")
I $G(NOPVTB) D Q
.K DIR
.S DIR(0)="E"
.S DIR("A")="Press RETURN to cont"
.D ^DIR
K DIR
S DIR("A")="CHANGE which item? (1-"_$G(AG("N"))_") NONE// "
D READ^AGED1
G END:Y=$G(AGOPT("ESCAPE"))
G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
Q:$D(DFOUT)!$D(DTOUT)
I +Y>0,(+Y<AG("N")+1),($G(AG("PLANEXP"))'=""),AG("PLANEXP")<DT D G VAR
. W !!,"This plan has expired. You may not edit it." H 2
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
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
S:$G(AGSELECT)'="" AGSELECT=$$FINDPVT^AGINSUPD(AGSELECT)
D UPDATE1^AGED(DUZ(2),ID0,3,"")
K AGI,AGY
G VAR
;CLEAN UP THE VARIABLES USED
END K AG,DA,DIC,DR,AGSCRN,COVREC
K ROUTID
Q
DRAW ;EP
D HDR
D GETAW
Q
HDR ;
S AGPAT=$P(^DPT(ID0,0),U)
S AGCHRT=$S($D(^AUPNPAT(ID0,41,DUZ(2),0)):$P(^AUPNPAT(ID0,41,DUZ(2),0),U,2),1:"xxxxx")
S AG("AUPN")=$G(^AUPNPAT(ID0,0))
S AGLINE("-")=$TR($J(" ",78)," ","-")
S AGLINE("EQ")=$TR($J(" ",78)," ","=")
S $P(AGLINE("PGLN"),"=",81)=""
W $$S^AGVDF("IOF"),!
S AG("PG")="4PVTB"
S ROUTID=$P($T(+1)," ") ;SET ROUTINE ID FOR PROGRAMMER VIEW
D PROGVIEW^AGUTILS(DUZ)
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
W ?31,"PRIVATE INSURANCE B"
W ?80-$L($P($G(^DIC(4,DUZ(2),0)),U)),$P($G(^DIC(4,DUZ(2),0)),U)
S AGLINE("-")=$TR($J(" ",80)," ","-")
S AGLINE("EQ")=$TR($J(" ",80)," ","=")
W !,AGLINE("EQ")
W !,$E(AGPAT,1,23)
W ?23,$$DTEST^AGUTILS(ID0)
I $D(AGCHRT) W ?42,"HRN#:",$G(AGCHRT)
;GET ELIGIBILITY STATUS
S AGELSTS=$P($G(^AUPNPAT(ID0,11)),U,12)
W ?56,"(",$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
W !,AGLINE("EQ")
K AG("EDIT")
Q
GETAW ;DISPLAY
S:$G(AGINSREC)'="" POLHPTR=$E($P($G(AGINSREC),U,7),2,10)
S:$G(AGINSREC)'="" COVPTR=$P($G(AGINSREC),U,3)
S:$G(AGINSREC)'="" AGINSPTR=$P(AGINSREC,U,2)
I COVPTR="" S NOPVTB=1 W !!,"NO COVERAGE TYPE FOUND FOR THIS PATIENT!",!,"COVERAGE TYPE CAN BE ADDED FOR A PATIENT ON THE FIRST PRIVATE INSURANCE PAGE",!,"Edit Item 11 and edit the Coverage field" H 3 Q
D LSTREC(COVPTR,.COVREC) ;GET COVREC TO BE USED WHEN EDITING THE AMOUNTS
I '$D(COVREC) D Q
.W !,"USE TABLE MAINTENANCE TO COMPLETE THE FIELD 'CO-PAY/DED RATES' FOR COVERAGE ",$P($G(^AUTTPIC(COVPTR,0)),U)
.S NOPVTB=1
.H 3
W $S(AGINSPTR'="":$E($P($G(^AUTNINS(AGINSPTR,0)),U),1,15),1:"UNDEFINED")
W:$P($G(^AUTTPIC(COVPTR,0)),U)'="" " ("_$E($P($G(^AUTTPIC(COVPTR,0)),U),1,15)_")"
S DIC=9999999.18,D0=AGINSPTR,DR=".39"
W ?50,"Network Provider : ",$$GET1^DIQ(DIC,D0,DR)
W !
S Y=$P($G(^AUTTPIC(COVPTR,19,COVREC,0)),U) I Y D DD^%DT W ?0,"EFF: ",Y K Y
S Y=$P($G(^AUTTPIC(COVPTR,0)),U,6),AG("PLANEXP")=Y I Y D DD^%DT W ?20,"EXP: ",Y K Y
W !!,"-OUTPATIENT",$E(AGLINE("-"),1,69)
K AG("C")
F AG=1:1 D Q:$G(AGSCRN)[("*END*")
. S D0=COVREC
. S AGSCRN=$P($T(@1+AG),";;",2,15)
. Q:AGSCRN[("*END*")
. I AG=4 W !,"-DAY SURGERY (ASC)",$E(AGLINE("-"),1,62)
. I AG=6 W !,"-INPATIENT",$E(AGLINE("-"),1,70)
. I AG=8 W !,"-DENTAL",$E(AGLINE("-"),1,72)
. I AG=9 W !,"-MENTAL HEALTH",$E(AGLINE("-"),1,66)
. I AG=10 W !,"-DEDUCTIBLE",$E(AGLINE("-"),1,69)
. S CAPTION=$P(AGSCRN,U) ;FIELD CAP
. S DIC=$P(AGSCRN,U,3) ;FILE OR SUBFILE #
. S DR=$P(AGSCRN,U,4) ;FLD #
. S NEWLINE=$P(AGSCRN,U,5) ;NEWLINE OR INDENT
. S CAPDENT=$P(AGSCRN,U,2) ;CAP INDENT
. S ITEMNUM=$P(AGSCRN,U,6) ;ITEM #
. S TAGCALL=$P($P(AGSCRN,"|"),U,7) ;TAG TO CALL TO EDIT THIS FLD
. S EXECUTE=$P(AGSCRN,"|",2) ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
. S PREEXEC=$P(AGSCRN,"|",3) ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
. S PRECAPEX=$P(AGSCRN,"|",4) ;PLACE CODE TO EXECUTE BEF CAPTION/FLD LABEL
. S POSTEXEC=$P(AGSCRN,"|",5) ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD
. S:TAGCALL'="" $P(AG("C"),",",ITEMNUM)=TAGCALL ;SELECTION STRING
. W @NEWLINE,AG,".",@CAPDENT,$S($G(CAPTION)'="":CAPTION,1:$P(^DD(DIC,DR,0),U)),": "
. I PREEXEC="" W $$GET1^DIQ(DIC,D0,DR)
. I PREEXEC'="" S D0=COVREC_","_COVPTR_"," X PREEXEC
. I EXECUTE'="" S D0=$TR(D0,",") X EXECUTE
S AG("N")=$L(AG("C"),",")
W !,$G(AGLINE("-"))
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="FINDPVT",MYVARS("SITE")=DUZ(2),MYVARS("SELECTION")=$G(AGSELECT)
D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
D VERIF^AGUTILS
Q
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; SUBROUTINES FOR EDITING FIELDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
OPCOPAY ;OUTPATIENT CO-PAYMENT
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".02"
D ^DIE
K DIC,DR,DIE,DA
Q
OPCOINS ;OUTPATIENT CO-INSURANCE
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".03"
D ^DIE
K DIC,DR,DIE,DA
Q
ERCOPAY ;ER CO-PAY
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".04"
D ^DIE
K DIC,DR,DIE,DA
Q
DSCOPAY ;DAY SURGERY CO-PAYMENT
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".05"
D ^DIE
K DIC,DR,DIE,DA
Q
DSCOINS ;DAY SURGERY CO-INSURANCE
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".06"
D ^DIE
K DIC,DR,DIE,DA
Q
IPCOPAY ;INPATIENT CO-PAYMENT
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".07"
D ^DIE
K DIC,DR,DIE,DA
Q
IPCOINS ;INPATIENT CO-INSURANCE
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".08"
D ^DIE
K DIC,DR,DIE,DA
Q
DENCOINS ;DENTAL CO-INSURANCE
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".09"
D ^DIE
K DIC,DR,DIE,DA
Q
MHDED ;MENTAL HEALTH DEDUCTIBLE
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".11"
D ^DIE
K DIC,DR,DIE,DA
Q
DEDFAM ;DEDUCTIBLE FAMILY
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".12"
D ^DIE
K DIC,DR,DIE,DA
Q
DEDIND ;DEDUCTIBLE INDIVIDUAL
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".13"
D ^DIE
K DIC,DR,DIE,DA
Q
DEDOOP ;DEDUCTIBLE OUT-OF-POCKET
K DIC,DR,DIE,DA,DD,DO
S DA=$G(COVREC)
S DA(1)=$G(COVPTR)
S DIE="^AUTTPIC("_DA(1)_",19,"
S DR=".14"
D ^DIE
K DIC,DR,DIE,DA
Q
LSTREC(COVPTR,COVREC) ;FIND MOST RECENT RECORD
S AG("COVDT")=$O(^AUTTPIC(COVPTR,19,"B",""),-1)
Q:AG("COVDT")=""
S COVREC=$O(^AUTTPIC(COVPTR,19,"B",AG("COVDT"),""),-1)
Q
; ****************************************************************
; ON LINES BELOW:
; U "^" DELIMITED
; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
; PIECE VAR DESC
; ----- -------- -----------------------------------------------
; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
; 2 CAPDENT POSITION ON LINE TO DISP CAP
; 3 DIC FILE OR SUBFILE NUMBER
; 4 DR FLD NUMBER
; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE LINE
; 6 ITEMNUM ITEM NUMBER ASSIGNMENT. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
; FLD ON THE SCREEN
; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
;
; BAR "|" DELIMITED
; PIECE VAR DESC
; ----- -------- ----------------------------------------------
; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFT FLD PRINT
; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS.
; USE TO SCREEN OUT PRINTING A FLD VALUE
; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
1 ;
;;Co-payment............($)^?5^9999999.6519^.02^!^1^OPCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Co-insurance.......(%)^?45^9999999.6519^.03^?45^2^OPCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
;;ER Co-pay.............($)^?5^9999999.6519^.04^!^3^ERCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Co-payment............($)^?5^9999999.6519^.05^!^4^DSCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Co-insurance.......(%)^?45^9999999.6519^.06^?45^5^DSCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
;;Co-payment............($)^?5^9999999.6519^.07^!^6^IPCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Co-insurance.......(%)^?45^9999999.6519^.08^?45^7^IPCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
;;Dental Co-insurance...(%)^?5^9999999.6519^.09^!^8^DENCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
;;Mental Health Deductible ^?5^9999999.6519^.11^!^9^MHDED||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Family................($)^?5^9999999.6519^.12^!^10^DEDFAM||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Individual........($)^?45^9999999.6519^.13^?45^11^DEDIND||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;Out-Of-pocket.........($)^?5^9999999.6519^.14^!^12^DEDOOP||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
;;*END*
AGEDPRVB ; IHS/ASDS/TPF - EDIT/DISPLAY PRIVATE PAGE B SCREEN ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
+2 ;
EN(ID0,ID1,NEWENTRY,AGINSREC,AGINSPTR,POLHPTR,COVPTR) ;EP - CALLED BY AGED4A
+1 SET AG("PG")="4PVTB"
+2 SET AGSELECT=$GET(AGINSREC)
VAR DO DRAW
+1 IF $DATA(AGSEENLY)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter Response"
DO ^DIR
QUIT
+2 IF $DATA(AGSEENLY)
QUIT
+3 WRITE !,AGLINE("EQ")
+4 IF $GET(NOPVTB)
Begin DoDot:1
+5 KILL DIR
+6 SET DIR(0)="E"
+7 SET DIR("A")="Press RETURN to cont"
+8 DO ^DIR
End DoDot:1
QUIT
+9 KILL DIR
+10 SET DIR("A")="CHANGE which item? (1-"_$GET(AG("N"))_") NONE// "
+11 DO READ^AGED1
+12 IF Y=$GET(AGOPT("ESCAPE"))
GOTO END
+13 IF $DATA(AG("ED"))&'$DATA(AGXTERN)
GOTO @("^AGED"_AG("ED"))
+14 IF $DATA(DLOUT)!(Y["N")!$DATA(DUOUT)
GOTO END
IF $DATA(AG("ERR"))
GOTO VAR
+15 IF $DATA(DFOUT)!$DATA(DTOUT)
QUIT
+16 IF +Y>0
IF (+Y<AG("N")+1)
IF ($GET(AG("PLANEXP"))'="")
IF AG("PLANEXP")<DT
Begin DoDot:1
+17 WRITE !!,"This plan has expired. You may not edit it."
HANG 2
End DoDot:1
GOTO VAR
+18 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
GOTO VAR
+19 SET AGY=Y
+20 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")))
+21 ;AFTER EDITING THE SELECTION MUST BE UPDATED SO ANY ERRORS CORRECTED WILL BE REFLECTED ON THE REDRAWN SCREEN
+22 IF $GET(AGSELECT)'=""
SET AGSELECT=$$FINDPVT^AGINSUPD(AGSELECT)
+23 DO UPDATE1^AGED(DUZ(2),ID0,3,"")
+24 KILL AGI,AGY
+25 GOTO VAR
+26 ;CLEAN UP THE VARIABLES USED
END KILL AG,DA,DIC,DR,AGSCRN,COVREC
+1 KILL ROUTID
+2 QUIT
DRAW ;EP
+1 DO HDR
+2 DO GETAW
+3 QUIT
HDR ;
+1 SET AGPAT=$PIECE(^DPT(ID0,0),U)
+2 SET AGCHRT=$SELECT($DATA(^AUPNPAT(ID0,41,DUZ(2),0)):$PIECE(^AUPNPAT(ID0,41,DUZ(2),0),U,2),1:"xxxxx")
+3 SET AG("AUPN")=$GET(^AUPNPAT(ID0,0))
+4 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",78)," ","-")
+5 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",78)," ","=")
+6 SET $PIECE(AGLINE("PGLN"),"=",81)=""
+7 WRITE $$S^AGVDF("IOF"),!
+8 SET AG("PG")="4PVTB"
+9 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+10 DO PROGVIEW^AGUTILS(DUZ)
+11 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+12 WRITE ?31,"PRIVATE INSURANCE B"
+13 WRITE ?80-$LENGTH($PIECE($GET(^DIC(4,DUZ(2),0)),U)),$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+14 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+15 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",80)," ","=")
+16 WRITE !,AGLINE("EQ")
+17 WRITE !,$EXTRACT(AGPAT,1,23)
+18 WRITE ?23,$$DTEST^AGUTILS(ID0)
+19 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",$GET(AGCHRT)
+20 ;GET ELIGIBILITY STATUS
+21 SET AGELSTS=$PIECE($GET(^AUPNPAT(ID0,11)),U,12)
+22 WRITE ?56,"(",$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
+23 WRITE !,AGLINE("EQ")
+24 KILL AG("EDIT")
+25 QUIT
GETAW ;DISPLAY
+1 IF $GET(AGINSREC)'=""
SET POLHPTR=$EXTRACT($PIECE($GET(AGINSREC),U,7),2,10)
+2 IF $GET(AGINSREC)'=""
SET COVPTR=$PIECE($GET(AGINSREC),U,3)
+3 IF $GET(AGINSREC)'=""
SET AGINSPTR=$PIECE(AGINSREC,U,2)
+4 IF COVPTR=""
SET NOPVTB=1
WRITE !!,"NO COVERAGE TYPE FOUND FOR THIS PATIENT!",!,"COVERAGE TYPE CAN BE ADDED FOR A PATIENT ON THE FIRST PRIVATE INSURANCE PAGE",!,"Edit Item 11 and edit the Coverage field"
HANG 3
QUIT
+5 ;GET COVREC TO BE USED WHEN EDITING THE AMOUNTS
DO LSTREC(COVPTR,.COVREC)
+6 IF '$DATA(COVREC)
Begin DoDot:1
+7 WRITE !,"USE TABLE MAINTENANCE TO COMPLETE THE FIELD 'CO-PAY/DED RATES' FOR COVERAGE ",$PIECE($GET(^AUTTPIC(COVPTR,0)),U)
+8 SET NOPVTB=1
+9 HANG 3
End DoDot:1
QUIT
+10 WRITE $SELECT(AGINSPTR'="":$EXTRACT($PIECE($GET(^AUTNINS(AGINSPTR,0)),U),1,15),1:"UNDEFINED")
+11 IF $PIECE($GET(^AUTTPIC(COVPTR,0)),U)'=""
WRITE " ("_$EXTRACT($PIECE($GET(^AUTTPIC(COVPTR,0)),U),1,15)_")"
+12 SET DIC=9999999.18
SET D0=AGINSPTR
SET DR=".39"
+13 WRITE ?50,"Network Provider : ",$$GET1^DIQ(DIC,D0,DR)
+14 WRITE !
+15 SET Y=$PIECE($GET(^AUTTPIC(COVPTR,19,COVREC,0)),U)
IF Y
DO DD^%DT
WRITE ?0,"EFF: ",Y
KILL Y
+16 SET Y=$PIECE($GET(^AUTTPIC(COVPTR,0)),U,6)
SET AG("PLANEXP")=Y
IF Y
DO DD^%DT
WRITE ?20,"EXP: ",Y
KILL Y
+17 WRITE !!,"-OUTPATIENT",$EXTRACT(AGLINE("-"),1,69)
+18 KILL AG("C")
+19 FOR AG=1:1
Begin DoDot:1
+20 SET D0=COVREC
+21 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,15)
+22 IF AGSCRN[("*END*")
QUIT
+23 IF AG=4
WRITE !,"-DAY SURGERY (ASC)",$EXTRACT(AGLINE("-"),1,62)
+24 IF AG=6
WRITE !,"-INPATIENT",$EXTRACT(AGLINE("-"),1,70)
+25 IF AG=8
WRITE !,"-DENTAL",$EXTRACT(AGLINE("-"),1,72)
+26 IF AG=9
WRITE !,"-MENTAL HEALTH",$EXTRACT(AGLINE("-"),1,66)
+27 IF AG=10
WRITE !,"-DEDUCTIBLE",$EXTRACT(AGLINE("-"),1,69)
+28 ;FIELD CAP
SET CAPTION=$PIECE(AGSCRN,U)
+29 ;FILE OR SUBFILE #
SET DIC=$PIECE(AGSCRN,U,3)
+30 ;FLD #
SET DR=$PIECE(AGSCRN,U,4)
+31 ;NEWLINE OR INDENT
SET NEWLINE=$PIECE(AGSCRN,U,5)
+32 ;CAP INDENT
SET CAPDENT=$PIECE(AGSCRN,U,2)
+33 ;ITEM #
SET ITEMNUM=$PIECE(AGSCRN,U,6)
+34 ;TAG TO CALL TO EDIT THIS FLD
SET TAGCALL=$PIECE($PIECE(AGSCRN,"|"),U,7)
+35 ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
SET EXECUTE=$PIECE(AGSCRN,"|",2)
+36 ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
SET PREEXEC=$PIECE(AGSCRN,"|",3)
+37 ;PLACE CODE TO EXECUTE BEF CAPTION/FLD LABEL
SET PRECAPEX=$PIECE(AGSCRN,"|",4)
+38 ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD
SET POSTEXEC=$PIECE(AGSCRN,"|",5)
+39 ;SELECTION STRING
IF TAGCALL'=""
SET $PIECE(AG("C"),",",ITEMNUM)=TAGCALL
+40 WRITE @NEWLINE,AG,".",@CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION,1:$PIECE(^DD(DIC,DR,0),U)),": "
+41 IF PREEXEC=""
WRITE $$GET1^DIQ(DIC,D0,DR)
+42 IF PREEXEC'=""
SET D0=COVREC_","_COVPTR_","
XECUTE PREEXEC
+43 IF EXECUTE'=""
SET D0=$TRANSLATE(D0,",")
XECUTE EXECUTE
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+44 SET AG("N")=$LENGTH(AG("C"),",")
+45 WRITE !,$GET(AGLINE("-"))
+46 KILL MYERRS,MYVARS
+47 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+48 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")="FINDPVT"
SET MYVARS("SITE")=DUZ(2)
SET MYVARS("SELECTION")=$GET(AGSELECT)
+49 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+50 DO VERIF^AGUTILS
+51 QUIT
+52 ;
+53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+54 ; SUBROUTINES FOR EDITING FIELDS
+55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+56 ;
OPCOPAY ;OUTPATIENT CO-PAYMENT
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".02"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
OPCOINS ;OUTPATIENT CO-INSURANCE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".03"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
ERCOPAY ;ER CO-PAY
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".04"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
DSCOPAY ;DAY SURGERY CO-PAYMENT
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".05"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
DSCOINS ;DAY SURGERY CO-INSURANCE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".06"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
IPCOPAY ;INPATIENT CO-PAYMENT
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".07"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
IPCOINS ;INPATIENT CO-INSURANCE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".08"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
DENCOINS ;DENTAL CO-INSURANCE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".09"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
MHDED ;MENTAL HEALTH DEDUCTIBLE
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".11"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
DEDFAM ;DEDUCTIBLE FAMILY
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".12"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
DEDIND ;DEDUCTIBLE INDIVIDUAL
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".13"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
DEDOOP ;DEDUCTIBLE OUT-OF-POCKET
+1 KILL DIC,DR,DIE,DA,DD,DO
+2 SET DA=$GET(COVREC)
+3 SET DA(1)=$GET(COVPTR)
+4 SET DIE="^AUTTPIC("_DA(1)_",19,"
+5 SET DR=".14"
+6 DO ^DIE
+7 KILL DIC,DR,DIE,DA
+8 QUIT
LSTREC(COVPTR,COVREC) ;FIND MOST RECENT RECORD
+1 SET AG("COVDT")=$ORDER(^AUTTPIC(COVPTR,19,"B",""),-1)
+2 IF AG("COVDT")=""
QUIT
+3 SET COVREC=$ORDER(^AUTTPIC(COVPTR,19,"B",AG("COVDT"),""),-1)
+4 QUIT
+5 ; ****************************************************************
+6 ; ON LINES BELOW:
+7 ; U "^" DELIMITED
+8 ; AGSCRN CONTAINS THE $TEXT OF EACH LINE BELOW STARTING AT TAG '1'
+9 ; PIECE VAR DESC
+10 ; ----- -------- -----------------------------------------------
+11 ; 1 CAPTION FLD CAP ASSIGNED BY PROGRAMMER OVERRIDES FLD LBL IF POPULATED
+12 ; 2 CAPDENT POSITION ON LINE TO DISP CAP
+13 ; 3 DIC FILE OR SUBFILE NUMBER
+14 ; 4 DR FLD NUMBER
+15 ; 5 NEWLINE NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE LINE
+16 ; 6 ITEMNUM ITEM NUMBER ASSIGNMENT. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
+17 ; FLD ON THE SCREEN
+18 ; 7 TAGCALL TAG TO CALL WHEN THIS FLD IS CHOSEN BY USER TO BE EDITED
+19 ;
+20 ; BAR "|" DELIMITED
+21 ; PIECE VAR DESC
+22 ; ----- -------- ----------------------------------------------
+23 ; 2 EXECUTE EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFT FLD PRINT
+24 ; 3 PREEXEC EXECUTE CODE TO DO BEF FLD PRINTS.
+25 ; USE TO SCREEN OUT PRINTING A FLD VALUE
+26 ; 4 PRECAPEX EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL.
+27 ; USE TO SCREEN OUT PRINTING A CAP/FLD LBL
+28 ; 5 POSTEXEC EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
1 ;
+1 ;;Co-payment............($)^?5^9999999.6519^.02^!^1^OPCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+2 ;;Co-insurance.......(%)^?45^9999999.6519^.03^?45^2^OPCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
+3 ;;ER Co-pay.............($)^?5^9999999.6519^.04^!^3^ERCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+4 ;;Co-payment............($)^?5^9999999.6519^.05^!^4^DSCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+5 ;;Co-insurance.......(%)^?45^9999999.6519^.06^?45^5^DSCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
+6 ;;Co-payment............($)^?5^9999999.6519^.07^!^6^IPCOPAY||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+7 ;;Co-insurance.......(%)^?45^9999999.6519^.08^?45^7^IPCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
+8 ;;Dental Co-insurance...(%)^?5^9999999.6519^.09^!^8^DENCOINS||W $J($$GET1^DIQ(DIC,D0,DR),8)
+9 ;;Mental Health Deductible ^?5^9999999.6519^.11^!^9^MHDED||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+10 ;;Family................($)^?5^9999999.6519^.12^!^10^DEDFAM||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+11 ;;Individual........($)^?45^9999999.6519^.13^?45^11^DEDIND||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+12 ;;Out-Of-pocket.........($)^?5^9999999.6519^.14^!^12^DEDOOP||W $J($$GET1^DIQ(DIC,D0,DR),8,2)
+13 ;;*END*
