AGED7B ; IHS/ASDS/TPF - EDIT/DISPLAY PRIVATE PAGE B SCREEN ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
EN ;
N INSPTR,POLHPTR
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-"_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),$D(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),DFN,3,"")
K AGI,AGY
G VAR
;CLEAN UP THE VARIBALES USED
END K AG,DA,DIC,DR,AGSCRN,COVREC
K ROUTID
Q:$D(AGXTERN)
Q:$D(DIROUT)
Q:$D(AGSEENLY)
Q:$D(DUOUT)
Q
DRAW ;EP
D HDR
D GETAW
Q
HDR ;
S AGPAT=$P(^DPT(DFN,0),U)
S AGCHRT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"xxxxx")
S AG("AUPN")=""
S:$D(^AUPNPAT(DFN,0)) AG("AUPN")=^(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(^DIC(4,DUZ(2),0),U)),$P(^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(DFN)
I $D(AGCHRT) W ?42,"HRN#:",AGCHRT
;GET ELIGIBILITY STATUS
S AGELSTS=$P($G(^AUPNPAT(DFN,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")
S DA=DFN
K AG("EDIT")
Q
GETAW ;DISPLAY
S POLHPTR=$E($P($G(AGINSREC),U,7),2,10)
S COVPTR=$P($G(AGINSREC),U,3)
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
S INSPTR=$P(AGINSREC,U,2)
W $S(INSPTR'="":$E($P($G(^AUTNINS(INSPTR,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=INSPTR,DR=".39"
W ?50,"Network Provider : ",$$GET1^DIQ(DIC,D0,DR)
W !
I $P($G(^AUTTPIC(COVPTR,19,COVREC,0)),U)'="" D
.S Y=$P(^AUTTPIC(COVPTR,19,COVREC,0),U) D DD^%DT W ?0,"EFF: ",Y
I $P($G(^AUTTPIC(COVPTR,0)),U,6)'="" D
.S Y=$P(^AUTTPIC(COVPTR,0),U,6),AG("PLANEXP")=Y D DD^%DT W ?20,"EXP: ",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*
AGED7B ; IHS/ASDS/TPF - EDIT/DISPLAY PRIVATE PAGE B SCREEN ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
EN ;
+1 NEW INSPTR,POLHPTR
+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-"_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 $DATA(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),DFN,3,"")
+24 KILL AGI,AGY
+25 GOTO VAR
+26 ;CLEAN UP THE VARIBALES USED
END KILL AG,DA,DIC,DR,AGSCRN,COVREC
+1 KILL ROUTID
+2 IF $DATA(AGXTERN)
QUIT
+3 IF $DATA(DIROUT)
QUIT
+4 IF $DATA(AGSEENLY)
QUIT
+5 IF $DATA(DUOUT)
QUIT
+6 QUIT
DRAW ;EP
+1 DO HDR
+2 DO GETAW
+3 QUIT
HDR ;
+1 SET AGPAT=$PIECE(^DPT(DFN,0),U)
+2 SET AGCHRT=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"xxxxx")
+3 SET AG("AUPN")=""
+4 IF $DATA(^AUPNPAT(DFN,0))
SET AG("AUPN")=^(0)
+5 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",78)," ","-")
+6 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",78)," ","=")
+7 SET $PIECE(AGLINE("PGLN"),"=",81)=""
+8 WRITE $$S^AGVDF("IOF"),!
+9 SET AG("PG")="4PVTB"
+10 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+11 DO PROGVIEW^AGUTILS(DUZ)
+12 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+13 WRITE ?31,"PRIVATE INSURANCE B"
+14 WRITE ?80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U)),$PIECE(^DIC(4,DUZ(2),0),U)
+15 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+16 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",80)," ","=")
+17 WRITE !,AGLINE("EQ")
+18 WRITE !,$EXTRACT(AGPAT,1,23)
+19 WRITE ?23,$$DTEST^AGUTILS(DFN)
+20 IF $DATA(AGCHRT)
WRITE ?42,"HRN#:",AGCHRT
+21 ;GET ELIGIBILITY STATUS
+22 SET AGELSTS=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+23 WRITE ?56,"(",$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING VERIFICATION",1:"NONE"),")"
+24 WRITE !,AGLINE("EQ")
+25 SET DA=DFN
+26 KILL AG("EDIT")
+27 QUIT
GETAW ;DISPLAY
+1 SET POLHPTR=$EXTRACT($PIECE($GET(AGINSREC),U,7),2,10)
+2 SET COVPTR=$PIECE($GET(AGINSREC),U,3)
+3 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
+4 ;GET COVREC TO BE USED WHEN EDITING THE AMOUNTS
DO LSTREC(COVPTR,.COVREC)
+5 SET INSPTR=$PIECE(AGINSREC,U,2)
+6 WRITE $SELECT(INSPTR'="":$EXTRACT($PIECE($GET(^AUTNINS(INSPTR,0)),U),1,15),1:"UNDEFINED")
+7 IF $PIECE($GET(^AUTTPIC(COVPTR,0)),U)'=""
WRITE " ("_$EXTRACT($PIECE($GET(^AUTTPIC(COVPTR,0)),U),1,15)_")"
+8 SET DIC=9999999.18
SET D0=INSPTR
SET DR=".39"
+9 WRITE ?50,"Network Provider : ",$$GET1^DIQ(DIC,D0,DR)
+10 WRITE !
+11 IF $PIECE($GET(^AUTTPIC(COVPTR,19,COVREC,0)),U)'=""
Begin DoDot:1
+12 SET Y=$PIECE(^AUTTPIC(COVPTR,19,COVREC,0),U)
DO DD^%DT
WRITE ?0,"EFF: ",Y
End DoDot:1
+13 IF $PIECE($GET(^AUTTPIC(COVPTR,0)),U,6)'=""
Begin DoDot:1
+14 SET Y=$PIECE(^AUTTPIC(COVPTR,0),U,6)
SET AG("PLANEXP")=Y
DO DD^%DT
WRITE ?20,"EXP: ",Y
End DoDot:1
+15 WRITE !!,"-OUTPATIENT",$EXTRACT(AGLINE("-"),1,69)
+16 KILL AG("C")
+17 FOR AG=1:1
Begin DoDot:1
+18 SET D0=COVREC
+19 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,15)
+20 IF AGSCRN[("*END*")
QUIT
+21 IF AG=4
WRITE !,"-DAY SURGERY (ASC)",$EXTRACT(AGLINE("-"),1,62)
+22 IF AG=6
WRITE !,"-INPATIENT",$EXTRACT(AGLINE("-"),1,70)
+23 IF AG=8
WRITE !,"-DENTAL",$EXTRACT(AGLINE("-"),1,72)
+24 IF AG=9
WRITE !,"-MENTAL HEALTH",$EXTRACT(AGLINE("-"),1,66)
+25 IF AG=10
WRITE !,"-DEDUCTIBLE",$EXTRACT(AGLINE("-"),1,69)
+26 ;FIELD CAP
SET CAPTION=$PIECE(AGSCRN,U)
+27 ;FILE OR SUBFILE #
SET DIC=$PIECE(AGSCRN,U,3)
+28 ;FLD #
SET DR=$PIECE(AGSCRN,U,4)
+29 ;NEWLINE OR INDENT
SET NEWLINE=$PIECE(AGSCRN,U,5)
+30 ;CAP INDENT
SET CAPDENT=$PIECE(AGSCRN,U,2)
+31 ;ITEM #
SET ITEMNUM=$PIECE(AGSCRN,U,6)
+32 ;TAG TO CALL TO EDIT THIS FLD
SET TAGCALL=$PIECE($PIECE(AGSCRN,"|"),U,7)
+33 ;USE TO DISP FLD WHICH IS DEPENDENT ON ANOTHER FLD
SET EXECUTE=$PIECE(AGSCRN,"|",2)
+34 ;PLACE CODE TO BE XECUTED PRIOR TO DISP OF THE FLD
SET PREEXEC=$PIECE(AGSCRN,"|",3)
+35 ;PLACE CODE TO EXECUTE BEF CAPTION/FLD LABEL
SET PRECAPEX=$PIECE(AGSCRN,"|",4)
+36 ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD
SET POSTEXEC=$PIECE(AGSCRN,"|",5)
+37 ;SELECTION STRING
IF TAGCALL'=""
SET $PIECE(AG("C"),",",ITEMNUM)=TAGCALL
+38 WRITE @NEWLINE,AG,".",@CAPDENT,$SELECT($GET(CAPTION)'="":CAPTION,1:$PIECE(^DD(DIC,DR,0),U)),": "
+39 IF PREEXEC=""
WRITE $$GET1^DIQ(DIC,D0,DR)
+40 IF PREEXEC'=""
SET D0=COVREC_","_COVPTR_","
XECUTE PREEXEC
+41 IF EXECUTE'=""
SET D0=$TRANSLATE(D0,",")
XECUTE EXECUTE
End DoDot:1
IF $GET(AGSCRN)[("*END*")
QUIT
+42 SET AG("N")=$LENGTH(AG("C"),",")
+43 WRITE !,$GET(AGLINE("-"))
+44 KILL MYERRS,MYVARS
+45 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+46 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")="FINDPVT"
SET MYVARS("SITE")=DUZ(2)
SET MYVARS("SELECTION")=$GET(AGSELECT)
+47 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+48 DO VERIF^AGUTILS
+49 QUIT
+50 ;
+51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+52 ; SUBROUTINES FOR EDITING FIELDS
+53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+54 ;
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*
