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