AGEDIT ; IHS/ASDS/EFG - MAIN ROUTINE FOR EDITING A PATIENT;
;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
;
PATLK ;EP -
S AG("PG")=0
D PTLK^AG
PATNLK ;PEP -- entry point for packages that already have patient name
S AG("PG")=0
Q:'$D(DFN)
S AGPATDFN=$G(DFN) ;AG*7.1*1 FIX PROBLEM WITH CURRENT PAT. IN EDIT SCREEN CHANGING WHEN PATIENT LOOKUP IS USED (DFN CHANGES)
L +^AUPNPAT(DFN):3 I '$T D Q
. W !,*7,"Patient's record is being used, Try again soon" H 2
;L +^DPT(DFN):5 I '$T W !,"Patient's DPT record already in use! Try again later!" H 2 Q
;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
I $$AGE^AGUTILS(AGPATDFN)<3,('$$DECEASED^AGEDERR2(AGPATDFN)) D AUTOADD^BIPATE(AGPATDFN,DUZ(2),.AGERR,"")
;END NEW CODE
S AUPNPAT=DFN
G:$D(AGXTERN)!($E($O(^AUPNPAT("D",999999)))'="T") SSNCK
W !!,*7,"There are patients on file with TEMPORARY CHART NUMBERS.",!!
W "Please print the list of these patients and supply the missing data.",!!
SSNCK ;
I $P($G(^DPT(DFN,0)),U,9)="" D G CONT
. W !?5,"**** WARNING: SSN MISSING ("
. W $S($P($G(^AUPNPAT(DFN,0)),U,24)=1:"Not Available",$P(^(0),U,24)=2:"Patient Refused",$P(^(0),U,24)=3:"Patient will Submit",1:"Reason for no SSN not yet entered")
. W ") *****",!!
E G:$D(AGXTERN)!($E($O(^AUPNPAT("D",999999)))'="T") DATCK
CONT ;
DATCK ;
D ^AGDATCK
I AG("DTOT")>0 D ^AGBADATA I $D(DUOUT)!$D(DTOUT)!$D(DFOUT) K:$D(AGXTERN) DFN Q
ELIG ;
K AG("ELIG")
I AGOPT(14)="Y" G BICELIG
I $D(^AUPNPAT(DFN,11)),$P(^(11),U,12)]"","I"[$P(^(11),U,12) D
. W !!,*7,"Patient has been designated ""INELIGIBLE"".",!!
. S AG("ELIG")=""
G CLASS
BICELIG ;
I $D(^AUPNPAT(DFN,11)),+$P(^(11),U,24)>2 D
. W !!,*7,"Patient has been designated:",!
. W $P(^AUTTBICE($P(^AUPNPAT(DFN,11),U,24),0),U),!!
. S AG("ELIG")=""
CLASS ;
I $D(^AUPNPAT(DFN,11)),$D(AG("ELIG")),$P(^(11),U,11)]"",$D(^AUTTBEN($P(^AUPNPAT(DFN,11),U,11),0)) W "Patient is classified as: ",$P(^(0),U),!! K DIR S DIR(0)="E" S DIR("A")="Press the RETURN key to continue. " D ^DIR
K AG("ELIG")
DFN ;Pre-determined patient (DFN) defined.
L1 ;
Q:'$D(DFN)
I "YC"[AGOPT(14) D
. S AG("SVELIG")=""
. I $D(^AUPNPAT(DFN,11)),$P(^(11),U,12)]"" S AG("SVELIG")=$P(^(11),U,12)
I '$D(^DPT(DFN,0)) K:$D(AGXTERN) DFN Q
S AGPAT=$P($G(^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)," ","=")
Q:$D(AGXTERN)
I '$D(AGXTERN) D EDCHEK
D ^AGED1
L -^AUPNPAT(DFN)
;L -^DPT(DFN) ;AG*7,1*2 ADDING APIS WITH EDITS
K DFOUT,DTOUT,DUOUT
K AGSELECT
Q
EDCHEK ;EP
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="",MYVARS("SITE")=DUZ(2)
D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
I $$PATREFBC^AGEDERR(DFN) W !!,"**PATIENT HAS AN OPEN BENEFITS CASE**"
W !
K DIR
S DIR("A")="Press the RETURN key to continue. "
S DIR(0)="E"
D ^DIR
Q
AGEDIT ; IHS/ASDS/EFG - MAIN ROUTINE FOR EDITING A PATIENT;
+1 ;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
+2 ;
PATLK ;EP -
+1 SET AG("PG")=0
+2 DO PTLK^AG
PATNLK ;PEP -- entry point for packages that already have patient name
+1 SET AG("PG")=0
+2 IF '$DATA(DFN)
QUIT
+3 ;AG*7.1*1 FIX PROBLEM WITH CURRENT PAT. IN EDIT SCREEN CHANGING WHEN PATIENT LOOKUP IS USED (DFN CHANGES)
SET AGPATDFN=$GET(DFN)
+4 LOCK +^AUPNPAT(DFN):3
IF '$TEST
Begin DoDot:1
+5 WRITE !,*7,"Patient's record is being used, Try again soon"
HANG 2
End DoDot:1
QUIT
+6 ;L +^DPT(DFN):5 I '$T W !,"Patient's DPT record already in use! Try again later!" H 2 Q
+7 ;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
+8 IF $$AGE^AGUTILS(AGPATDFN)<3
IF ('$$DECEASED^AGEDERR2(AGPATDFN))
DO AUTOADD^BIPATE(AGPATDFN,DUZ(2),.AGERR,"")
+9 ;END NEW CODE
+10 SET AUPNPAT=DFN
+11 IF $DATA(AGXTERN)!($EXTRACT($ORDER(^AUPNPAT("D",999999)))'="T")
GOTO SSNCK
+12 WRITE !!,*7,"There are patients on file with TEMPORARY CHART NUMBERS.",!!
+13 WRITE "Please print the list of these patients and supply the missing data.",!!
SSNCK ;
+1 IF $PIECE($GET(^DPT(DFN,0)),U,9)=""
Begin DoDot:1
+2 WRITE !?5,"**** WARNING: SSN MISSING ("
+3 WRITE $SELECT($PIECE($GET(^AUPNPAT(DFN,0)),U,24)=1:"Not Available",$PIECE(^(0),U,24)=2:"Patient Refused",$PIECE(^(0),U,24)=3:"Patient will Submit",1:"Reason for no SSN not yet entered")
+4 WRITE ") *****",!!
End DoDot:1
GOTO CONT
+5 IF '$TEST
IF $DATA(AGXTERN)!($EXTRACT($ORDER(^AUPNPAT("D",999999)))'="T")
GOTO DATCK
CONT ;
DATCK ;
+1 DO ^AGDATCK
+2 IF AG("DTOT")>0
DO ^AGBADATA
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
IF $DATA(AGXTERN)
KILL DFN
QUIT
ELIG ;
+1 KILL AG("ELIG")
+2 IF AGOPT(14)="Y"
GOTO BICELIG
+3 IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,12)]""
IF "I"[$PIECE(^(11),U,12)
Begin DoDot:1
+4 WRITE !!,*7,"Patient has been designated ""INELIGIBLE"".",!!
+5 SET AG("ELIG")=""
End DoDot:1
+6 GOTO CLASS
BICELIG ;
+1 IF $DATA(^AUPNPAT(DFN,11))
IF +$PIECE(^(11),U,24)>2
Begin DoDot:1
+2 WRITE !!,*7,"Patient has been designated:",!
+3 WRITE $PIECE(^AUTTBICE($PIECE(^AUPNPAT(DFN,11),U,24),0),U),!!
+4 SET AG("ELIG")=""
End DoDot:1
CLASS ;
+1 IF $DATA(^AUPNPAT(DFN,11))
IF $DATA(AG("ELIG"))
IF $PIECE(^(11),U,11)]""
IF $DATA(^AUTTBEN($PIECE(^AUPNPAT(DFN,11),U,11),0))
WRITE "Patient is classified as: ",$PIECE(^(0),U),!!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press the RETURN key to continue. "
DO ^DIR
+2 KILL AG("ELIG")
DFN ;Pre-determined patient (DFN) defined.
L1 ;
+1 IF '$DATA(DFN)
QUIT
+2 IF "YC"[AGOPT(14)
Begin DoDot:1
+3 SET AG("SVELIG")=""
+4 IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,12)]""
SET AG("SVELIG")=$PIECE(^(11),U,12)
End DoDot:1
+5 IF '$DATA(^DPT(DFN,0))
IF $DATA(AGXTERN)
KILL DFN
QUIT
+6 SET AGPAT=$PIECE($GET(^DPT(DFN,0)),U)
+7 SET AGCHRT=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"xxxxx")
+8 SET AG("AUPN")=""
+9 IF $DATA(^AUPNPAT(DFN,0))
SET AG("AUPN")=^(0)
+10 SET AGLINE("-")=$TRANSLATE($JUSTIFY(" ",78)," ","-")
+11 SET AGLINE("EQ")=$TRANSLATE($JUSTIFY(" ",78)," ","=")
+12 IF $DATA(AGXTERN)
QUIT
+13 IF '$DATA(AGXTERN)
DO EDCHEK
+14 DO ^AGED1
+15 LOCK -^AUPNPAT(DFN)
+16 ;L -^DPT(DFN) ;AG*7,1*2 ADDING APIS WITH EDITS
+17 KILL DFOUT,DTOUT,DUOUT
+18 KILL AGSELECT
+19 QUIT
EDCHEK ;EP
+1 KILL MYERRS,MYVARS
+2 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+3 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SITE")=DUZ(2)
+4 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+5 IF $$PATREFBC^AGEDERR(DFN)
WRITE !!,"**PATIENT HAS AN OPEN BENEFITS CASE**"
+6 WRITE !
+7 KILL DIR
+8 SET DIR("A")="Press the RETURN key to continue. "
+9 SET DIR(0)="E"
+10 DO ^DIR
+11 QUIT
