Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGEDPRVB

AGEDPRVB.m

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