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

AGEDMCD.m

Go to the documentation of this file. 
  1. AGEDMCD ; IHS/ASDS/TPF - NEW EDIT/DISP MCD SCREEN - REPLACES AGED5 AND AGED51 ;    
  1.  ;;7.1;PATIENT REGISTRATION;**1,2,11**;AUG 25, 2005;Build 1
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
  1.  ;
  1. EN(WD0,WD1,NEWENTRY,AGSELECT,AGOPTION) ;EP
  1.  S AG("PG")="4MCDA"
  1.  K DEFEDDT
  1.  S EXIT=0
  1.  I NEWENTRY D  Q:EXIT
  1.  .S EXIT=0
  1.  .D DRAW,NEWENTRY I +$G(Y)<0 S EXIT=1 W !,"Entry could not be created." H 2 D END Q
  1.  .D MSG,MEDSTATE
  1.  .D AEFFDT I +$G(Y)<0 D CLEANZER(WD0) S EXIT=1 W !,"New entry not made" H 2 D END Q
  1.  .D MEDNUM
  1.  .D MEDNAME
  1.  .D MEDDOB
  1.  .D:$G(^AGFAC(DUZ(2),"NEWADDINS"))&($P($G(AGOPTION),U)="AGADD") PCP,GRPNAME,PLANNM,RATECD,CCONFILE
  1.  .S COMPIEN=WD0_",11,"_WD1_","_0
  1.  .;S AGSELECT=$$UPDTSEL^AGUTILS("FINDMCD",.AGINS,COMPIEN)
  1.  .S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,AGELP("INS"))  ;AG*7.1*1 IM18549 ERROR IN ERROR MSG UPDATE
  1.  .S NEWENTRY=0
  1.  S COMPIEN=WD0_",11,"_WD1_","_0
  1. VAR D DRAW
  1.  Q:$D(AGSEENLY)
  1.  W !,AGLINE("EQ")
  1.  K DIR
  1.  S DIR("A")="ENTER <E>dit a field OR <D>elete an eligibility date :"
  1.  S DIR(0)="SAO^E:EDIT;D:DELETE"
  1.  D ^DIR
  1.  I Y="",'$O(^AUPNMCD(WD0,11,0)) D CLEAN(WD0) D END Q
  1.  I $D(MYERRS("C","E"))&(Y'?1N.N)&(Y'="E")&(Y'="D")&(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE EDIT AND FIX BEFORE EXITING!!" H 3 G VAR
  1.  Q:Y=AGOPT("ESCAPE")
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  I Y="A" D AEFFDT G VAR
  1.  I Y="D" D  Q:'$D(^AUPNMCD(WD0))  G VAR
  1.  .D EFFDT
  1.  .I '$O(^AUPNMCD(WD0,11,0)) D CLEAN(WD0),END
  1.  K DIR
  1.  S DIR("?")="Enter your choice now."
  1.  S DIR("?",1)="You may enter the item number of the field to edit,"
  1.  S DIR("?",2)="OR 'P#' where P stands for 'page' and '#' stands for"
  1.  S DIR("?",3)="the page to jump to, OR enter '^' to go back one page"
  1.  S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
  1.  S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
  1.  D READ^AGED1
  1.  I Y[(",") G CONT
  1.  I $D(MYERRS("C","E")),(Y'?1N.N),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR
  1.  Q:Y=AGOPT("ESCAPE")
  1.  G END:$D(DLOUT)!(Y["N")!$D(DUOUT),VAR:$D(AG("ERR"))
  1.  Q:$D(DFOUT)!$D(DTOUT)
  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. CONT ;
  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.  ;S AGSELECT=$$UPDTSEL^AGUTILS("FINDMCD",.AGINS,COMPIEN)
  1.  S AGSELECT=$$UPDTSEL^AGUTILS(.AGINS,COMPIEN,$P(AGSELECT,U,2))  ;AG*7.1*1 IM18549 ERROR IN ERROR MSG UPDATE
  1.  D UPDATE1^AGED(DUZ(2),DFN,3,"")
  1.  N DIE,DA,DR
  1.  S DIE="^AUPNMCD("
  1.  S DA=WD0
  1.  S DR=".08///TODAY"
  1.  D ^DIE
  1.  K AGI,AGY
  1.  G VAR
  1. CLEAN(WD0) ;IF NO ELIG DTS, CLEAN EMPTY RECORD.
  1.  D CLEANZER(WD0)
  1.  Q
  1. CLEANZER(WD0) ;EP - CLEAN ZERO NODE WITH NO DTS
  1.  K DIK,DA
  1.  S DIK="^AUPNMCD(",DA=WD0 D ^DIK
  1.  Q
  1. END K AG,DLOUT,DTOUT,DFOUT,DQOUT,DA,DIC,DR,AGSCRN,Y,ADA,WDA,ADT,WDT
  1.  K ADFN,WDFN,REC,DEFEDDT,DATESORT,AGERRSOL,MYERRS,MYVARS
  1.  Q
  1. DRAW ;EP
  1.  S AG("PG")="4MCDA"
  1.  S ROUTID=$P($T(+1)," ")
  1.  ;D HDR
  1.  D HDR^AGEDMCD1  ;AG*7.1*1 PER SAC REQUIREMENT RTN TOO LARGE
  1.  D GETAW
  1.  Q
  1. GETAW ;DISP
  1.  K AG("C")
  1.  ;F AG=1:1 D  Q:$G(AGSCRN)[("*END*")
  1.  F AG=1:1 D  Q:$G(AGSCRN)[("*END*")!(EXIT)
  1.  . S AGSCRN=$P($T(@1+AG),";;",2,15)
  1.  . Q:AGSCRN[("*END*")
  1.  . ;PLACE SECTION TITLES HERE
  1.  . S CAPTION=$P(AGSCRN,U)  ;FLD 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(AGSCRN,U,7)  ;TAG TO CALL TO EDIT THIS FLD
  1.  . S EXECUTE=$P(AGSCRN,"|",2)  ;USE TO DISP FLD WHICH IS DEPENDENT ON OTHER 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 CAP/FLD LBL
  1.  . S POSTEXEC=$P(AGSCRN,"|",5)  ;PLACE CODE HERE TO BE EXECUTED AFT DISP OF THE FLD DATA
  1.  . S:TAGCALL'="" $P(AG("C"),",",ITEMNUM)=TAGCALL  ;SELECTION STRING
  1.  . ;WRITE THE ITEM #,CAP OR FLD LBL, AND LINE
  1.  . W @NEWLINE
  1.  . W ITEMNUM
  1.  . W $S(ITEMNUM'="":". ",1:"")
  1.  . I PRECAPEX="" W @CAPDENT,$S($G(CAPTION)'="":CAPTION_": ",$G(CAPTION)="":"",1:$P($G(^DD(DIC,DR,0)),U)_": ")
  1.  . I PRECAPEX'="" X PRECAPEX I $T W @CAPDENT,$S($G(CAPTION)'="":CAPTION_": ",$G(CAPTION)="":"",1:$P($G(^DD(DIC,DR,0)),U)_": ")
  1.  .;IF EDITING, DISP DATA ONLY
  1.  .;E DISP ONLY THE CAPS
  1.  .I 'NEWENTRY D
  1.  .. S D0=WD0
  1.  .. I DIC'["." D
  1.  ... S D0=D0_","
  1.  ... I PREEXEC'="" X PREEXEC I $T W $$GET1^DIQ(DIC,D0,DR)
  1.  ... ;DO NOT PRINT FLD FIRST IF EXECUTE EXISTS
  1.  ... I PREEXEC="",EXECUTE="" W $$GET1^DIQ(DIC,D0,DR)
  1.  ... ;IHS/SD/TPF 9/27/2005 AG*7.1*1 FIX SO STATE FIELD CAN BE POPULATED IF FOUND NOT SO
  1.  ... I DR=.04 S STATEVAL=$$GET1^DIQ(DIC,D0,DR)
  1.  ... I AG=2 D
  1.  .... N DIE,D0,DR
  1.  .... S DIC=9000004
  1.  .... S D0=WD0
  1.  .... S DR=".08"
  1.  .... W ?21,"("_$$GET1^DIQ(DIC,D0,DR)_")"
  1.  ... I EXECUTE'="" S D0=$TR(D0,",") X EXECUTE
  1.  ... I POSTEXEC'="" X POSTEXEC
  1.  .. I DIC["."  D
  1.  ... S D0=WD1_","_D0_","
  1.  ... ;D GETDATES(WD0)
  1.  ... D GETDATES^AGEDMCD1(WD0)  ;AG*7.1*1 SAC REQUIREMENT RTN TOO LARGE
  1.  S AG("N")=$L(AG("C"),",")
  1.  W !,$G(AGLINE("-"))
  1.  ;IHS/SD/TPF 9/28/2005 AG*7.1*1 MANDATORY FIELD
  1.  ;I $G(STATEVAL)="",('$G(NEWENTRY)) W !,"STATE FIELD MUST BE POPULATED" D MEDSTATE I X="" W !,"STATE NOT ENTERED, THIS RECORD WILL BE DELETED"
  1.  I '$D(AGSEENLY),($G(STATEVAL)=""),('$G(NEWENTRY)) W !,"STATE FIELD MUST BE POPULATED" D MEDSTATE D:X'="" UPDATE1^AGED(DUZ(2),DFN,3,"") I X="" W !,"STATE NOT ENTERED, THIS RECORD WILL BE DELETED"  ;AG*7.1*2 IM21493
  1.  K MYERRS,MYVARS
  1.  D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
  1.  S MYVARS("DFN")=$S($G(AUPNPAT)'="":AUPNPAT,1:DFN),MYVARS("FINDCALL")="FINDMCD",MYVARS("SELECTION")=$G(AGSELECT),MYVARS("SITE")=DUZ(2)
  1.  I '$G(NEWENTRY) D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
  1.  W !,$G(AGLINE("-"))
  1.  D VERIF^AGUTILS
  1.  I $D(AGSEENLY) S DIR("A")="Press return: ",DIR(0)="FO" D ^DIR Q
  1.  Q
  1. MSG ;DISP IF NEW ENTRY
  1.  W !,"You have entered a new record for "_$P($G(^DPT(DFN,0)),U)_" in the MEDICAID file."
  1.  Q
  1.  ; MCD ELIG FLDS
  1. NEWENTRY ;NEW ENTRY
  1.  W !!
  1.  N TEMPDFN
  1.  K DIC,DIE,DR,DA,DO,DD,DIR
  1.  S DIC="^AUPNMCD("
  1.  S DIC(0)="LN"
  1.  S X="`"_DFN
  1.  S TEMPDFN=DFN
  1.  S DIC("S")="I $P(^(0),U)'=TEMPDFN,($G(Y)'=TEMPDFN)"  ;WHEN ADDING IGNORE ENTRIES ALREADY THERE, ALSO DO NOT LOOK UP ENTRIES IN AUPNMCD WHICH = DFN
  1.  D ^DIC
  1.  S DFN=TEMPDFN
  1.  Q:+Y'>0
  1.  S ADDCHK=""
  1.  S WD0=+Y
  1.  S NEWENTRY=0
  1.  S DIE=DIC
  1.  S DA=WD0
  1.  ;FORCE INSPTR TO BE "MEDICAID"
  1.  S AGELP("INS")=$O(^AUTNINS("B","MEDICAID",""))
  1.  S DR=".02////^S X=AGELP(""INS"")"
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 - STUFF PT SEX INTO ELIGIBLE SEX FIELD - START NEW CODE
  1.  N AGSEX
  1.  S AGSEX=$$GET1^DIQ(2,DFN,.02,"I")
  1.  S DR=DR_";.07////^S X=AGSEX"
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 - END NEW CODE
  1.  D ^DIE
  1.  Q
  1. MEDSTATE ;MCD ST EDIT FOR NEW ENTRY
  1.  K DIC,DIE,DR
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  S DR=".04"
  1.  S DIE("NO^")=""
  1.  D ^DIE
  1.  K DIC,DR,DIE
  1.  Q
  1. AEFFDT ;ADD EFF DT
  1.  K DIC,DIE,DR
  1.  I $G(WD1)'="" S DIC("B")=WD1
  1.  I $G(DEFEDDT)'="" S DIC("B")=DEFEDDT   ;IF DEFAULT USE IT
  1.  I '$D(^AUPNMCD(WD0,11,0)) S ^AUPNMCD(WD0,11,0)="^9000004.11D^0^0"
  1.  S DA(1)=WD0
  1.  S DIC="^AUPNMCD("_DA(1)_",11,"
  1.  S DLAYGO=9000004.11
  1.  S DIC(0)="AEL"
  1.  S DIC("A")="Select ELIG. DATE: "
  1.  D ^DIC
  1.  Q:+Y<1
  1.  S WD1=+Y
  1.  I $P(Y,U,3) D ENDDATE Q
  1.  K DIC,DIE,DR,DA
  1. EFFDT ;ELIG DTS AND COV TYPE
  1.  K DIC,DIE,DR,DA
  1.  I WD1="" D AEFFDT Q  ;IF WD1 IS NULL, EFF DTS WERE ALL CANCELLED
  1.  ;BEGIN NEW CODE IHS/SD/TPF 10/11/2005 AG*7.1*1
  1.  ;REINSTATE CHECK FOR ENTRIES IN 3PB FILES
  1.  K IN3PB
  1.  S IN3PB=$$USED^AGUTILS(DFN,$P($G(AGSELECT),U,2),7,WD1,WD0)
  1.  I $L(IN3PB) D  Q:$G(CANCELED)
  1.  .W !?15,"WARNING: This member has outstanding claims and/or bills!!!"
  1.  .W !?24,"Deleting an eligiblity date may cause data integrity problems"
  1.  .W !?24,"in the Third Party Billing package!!"
  1.  .K DIR,DIE,DA,DIC,DR
  1.  .S DIR(0)="Y"
  1.  .S DIR("B")="N"
  1.  .S DIR("A")="Continue?"
  1.  .D ^DIR
  1.  .S CANCELED=Y=0
  1.  ;END NEW CODE
  1.  S DA=WD1
  1.  S DA(1)=WD0
  1.  S DIE="^AUPNMCD("_DA(1)_",11,"
  1.  S DR=".01"
  1.  S DR(2,9000004.11)=".01"
  1.  D ^DIE
  1.  K DIC,DR,DIE
  1.  Q:'$D(DA)  ;IF NO DA, ENTRY WAS DELETED
  1.  ;COMPARE EFF AND EXP DTS
  1.  I '$$GOODDT(WD0,WD1) G EFFDT
  1. ENDDATE ;
  1.  K DIC,DIE,DR
  1.  S DA=WD1
  1.  S DA(1)=WD0
  1.  S DIE="^AUPNMCD("_DA(1)_",11,"
  1.  S DR=".02"
  1.  D ^DIE
  1.  K DIC,DR,DIE
  1.  ;COMPARE EFF AND EXP DTS
  1.  I '$$GOODDT(WD0,WD1) G ENDDATE
  1. COVTYPE ;
  1.  K DIC,DIE,DR
  1.  S DA=WD1
  1.  S DA(1)=WD0
  1.  S DIE="^AUPNMCD("_DA(1)_",11,"
  1.  ;CHK INSURER FILE. IS COV TYPE REQ'D
  1.  ;I '$$30^AGEROVR(30,$G(AGSELECT)) D   ;AG*7.1*1 IM20154
  1.  I '$$30^AGEROVR(30,$S($G(AGSELECT)'="":$G(AGSELECT),1:U_$G(AGELP("INS"))_U)) D
  1.  . S DR=".03R"
  1.  . S DIE("NO^")=""
  1.  E  S DR=".03"
  1.  D ^DIE
  1.  K DIC,DR,DIE
  1.  D OVERLAP(WD0,WD1)
  1.  Q
  1. OVERLAP(WD0,WD1) ;EP - DETERMINE OVERLAPPING ELIG RANGES
  1.  ;GET TARGET INFO
  1.  S TDT1=WD1
  1.  S TDT2=$P($G(^AUPNMCD(WD0,11,WD1,0)),U,2)
  1.  S TTYP=$P($G(^AUPNMCD(WD0,11,WD1,0)),U,3)
  1.  S OVERLAP=0
  1.  S DT1=""
  1.  S OPENEND=0
  1.  S DT1=0
  1.  F  S DT1=$O(^AUPNMCD(WD0,11,DT1)) Q:DT1=""!(OVERLAP)  D
  1.  .Q:DT1=TDT1  ;IF ITS THE SAME ENTRY THEY JUST PUT IN SKIP
  1.  .S TYP=$P($G(^AUPNMCD(WD0,11,DT1,0)),U,3)
  1.  .Q:TYP'=TTYP  ;IF THE TYPE OF COV NOT THE SAME IT DOESN'T MATTER
  1.  .S DT2=$P($G(^AUPNMCD(WD0,11,DT1,0)),U,2)
  1.  .I DT2="" S DT2=9999999
  1.  .I TDT1=DT2 S OVERLAP=1 Q
  1.  .I TDT1>DT1,(TDT1<DT2) S OVERLAP=1 Q
  1.  I OVERLAP D
  1.  .W !!,"YOU HAVE ENTERED A COVERAGE DATE RANGE WHICH OVERLAPS WITH ANOTHER ALREADY"
  1.  .W !,"EXISTING FOR THIS PATIENT! THE ENTRY WILL NOT BE ALLOWED!" H 3
  1.  .;ELIG DTS AND COV TYPE
  1.  .K DIC,DIE,DR
  1.  .I WD1="" D AEFFDT Q  ;IF WD1 IS NULL, EFF DTS WERE ALL CANCELLED
  1.  .S DA=WD1
  1.  .S DA(1)=WD0
  1.  .S DIE="^AUPNMCD("_DA(1)_",11,"
  1.  .S DR=".01////@"
  1.  .S DR(2,9000004.11)=".01"
  1.  .D ^DIE
  1.  .K DIC,DR,DIE
  1.  Q
  1. MEDNUM ;MCD #
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  S DR=".03"
  1.  S DIE("NO^")=""
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. MEDNAME ;MCD NAME
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  S DR="2101"
  1.  I $G(NEWENTRY)!($P($G(^AUPNMCD(WD0,21)),U)="") S DR=DR_"//"_$P($G(^DPT(DFN,0)),U)
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. MEDDOB ;MCD DOB
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  S DR="2102"
  1.  I $G(NEWENTRY)!($P($G(^AUPNMCD(WD0,21)),U,2)="") N AGDOB,Y S Y=$P($G(^DPT(DFN,0)),U,3) X ^DD("DD") S AGDOB=Y S DR=DR_"//"_AGDOB
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA,AGDOB
  1.  Q
  1. PCP ;PRIM CARE PROV
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  S DR=".14"
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. GRPNAME ;GRP NAME
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  S DR=".17"
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. PLANNM ;PLAN NAME
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  ;CHK INSURER FILE. IS PLAN NAME REQ'D
  1.  ;I '$$20^AGEROVR(20,$G(AGSELECT)) D  ;AG*7.1*1 IM20154 
  1.  I '$$20^AGEROVR(20,$S($G(AGSELECT)'="":$G(AGSELECT),1:U_$G(AGELP("INS"))_U)) D
  1.  . S DR=".11R"
  1.  . S DIE("NO^")=""
  1.  E  S DR=".11"
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. RATECD ;RATE CODE
  1.  W !
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  ;CHK INSURER FILE. IS RATE REQ'D
  1.  ;I '$$31^AGEROVR(31,$G(AGSELECT)) D  ;AG*7.1*1 IM20154
  1.  I '$$31^AGEROVR(31,$S($G(AGSELECT)'="":$G(AGSELECT),1:U_$G(AGELP("INS"))_U)) D
  1.  . S DR=".12R"
  1.  . S DIE("NO^")=""
  1.  E  S DR=".12"
  1.  D ^DIE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. CCONFILE ;CC ON FILE
  1.  W !
  1.  K DIC,DR,DIE,DA,DD,DO
  1.  S DA=WD0
  1.  S DIE="^AUPNMCD("
  1.  ;S DR=".15;.16"
  1.  ;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 ITEM 5
  1.  S DR=.15
  1.  D ^DIE
  1.  I $P($G(^AUPNMCD(WD0,0)),U,15)[("Y") D
  1.  .K DIC,DR,DIE,DA
  1.  .S DA=WD0
  1.  .S DIE="^AUPNMCD("
  1.  .S DR=".16R",DIE("NO^")=""
  1.  .D ^DIE
  1.  I $P($G(^AUPNMCD(WD0,0)),U,15)[("N") D
  1.  .K DIC,DR,DIE,DA
  1.  .S DA=WD0
  1.  .S DIE="^AUPNMCD("
  1.  .S DR=".16////@"
  1.  .D ^DIE
  1.  ;END NEW CODE
  1.  K DIC,DR,DIE,DA
  1.  Q
  1. GOODDT(AD0,AD1) ;EP -
  1.  N BDT,EDT
  1.  S BDT=$P($G(^AUPNMCD(WD0,11,WD1,0)),U)
  1.  S EDT=$P($G(^AUPNMCD(WD0,11,WD1,0)),U,2)
  1.  I EDT,'BDT W !,"CANNOT HAVE AN ENDING DATE WITHOUT A BEGINNING DATE! TRY AGAIN" Q 0
  1.  I EDT<BDT&(+EDT'=0) W !,"ENDING DATE IS LESS THAN THE EFFECTIVE DATE! TRY AGAIN" Q 0
  1.  I BDT>EDT&(+EDT'=0) W !,"EFFECTIVE DATE IS GREATER THAN THE ENDING DATE! TRY AGAIN" Q 0
  1.  Q 1
  1.  ; ****************************************************************
  1.  ; ON LINES BELOW:
  1.  ; U "^" DELIMITED
  1.  ; PIEC  1= FLD LBL
  1.  ; PIECE 2= POS ON LINE TO DISP ITEM #
  1.  ; PIECE 3= FILE #
  1.  ; PIECE 4= FLD #
  1.  ; PIECE 5= NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE CAP
  1.  ; PIECE 6= ITEM # OVERIDE. USE THIS TO ASSIGN THE ITEM # TO CHOOSE THIS
  1.  ;          FLD ON THE SCREEN
  1.  ; PIECE 7= TAG TO CALL WHEN THIS FLD IS CHOSEN TO EDIT
  1.  ;
  1.  ; BAR "|" DELIMITED
  1.  ; PIECE 2= EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFT FLD PRINT
  1.  ; PIECE 3= EXECUTE CODE TO DO BEF FLD DATA PRINTS. USE TO SCREEN OUT PRINTING A FLDS DATA
  1.  ; PIECE 4= EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL. USE TO SCREEN OUT PRINTING A CAP/FLD LBL
  1.  ; PIECE 5= EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
  1.  ;;^?3^9000004.11^.03^?59^^^
  1.  ;;^?3^9000004.11^.02^?68^^
  1. 1 ;
  1.  ;;STATE^?3^9000004^.04^!^^
  1.  ;;^?0^9000004^.03^!^1^MEDNUM
  1.  ;;^?3^9000004.11^.01^?36^2^AEFFDT
  1.  ;;MEDICAID NAME^?3^9000004^2101^!!^3^MEDNAME
  1.  ;;MED. DATE OF BIRTH^?3^9000004^2102^?45^4^MEDDOB
  1.  ;;PRIM CARE PROVIDER^?3^9000004^.14^!^5^PCP
  1.  ;;GROUP NAME^?3^9000004^.17^!^6^GRPNAME
  1.  ;;GROUP NUMBER^?3^9000004^.17^?45^^^|W $S($$GET1^DIQ(DIC,D0,DR,"I"):$P($G(^AUTNEGRP($$GET1^DIQ(DIC,D0,DR,"I"),0)),U,2),1:"")
  1.  ;;PLAN NAME^?3^9000004^.11^!^7^PLANNM
  1.  ;;RATE CODE^?3^9000004^.12^!^8^RATECD
  1.  ;;CC ON FILE^?3^9000004^.15^!^9^CCONFILE
  1.  ;;DATE^?3^9000004^.16^?28^^^||I $D(D0),$$GET1^DIQ(DIC,D0,.15,"I")="Y"|I $D(D0),$$GET1^DIQ(DIC,D0,.15,"I")="Y"
  1.  ;;*END*