AG0 ; IHS/ASDS/EFG - Add a patient opening page ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**1,2,7,8,9,10**;AUG 25, 2005;Build 7
;
K DOG,AGDOG
;
DOG ;PEP - From Other Systems.
D ^AGVAR
I $D(DOG) S AGDOG=DOG ;renamespace external call variable
VAR ;
W:$D(AGDOG) @IOF,!,"ADD a new patient......"
K AG,DFN
R1 ;
G L0:$D(DFN)
;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
;K DIR
;S DIR(0)="Y"
;S DIR("B")="YES"
;S DIR("A")="Do you wish to SCAN FOR SIMILAR NAMES or CHART NUMBERS? (Y/N) "
;S DIR("T")=DTIME
;D ^DIR
;Q:$D(DFOUT)!$D(DTOUT)!$D(DUOUT)
;G L0:Y=0
;G R2:Y=1!$D(DLOUT)
;G R1
;END IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
R2 ;
W !!,"You must first SCAN FOR SIMILAR NAMES or CHART NUMBERS NOW..." ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
K DIC
S DIC("W")="D ^AGSCANP"
D SET^AUPNLKZ ; Set DUZ(2) to 0
D PTLK^AG ; Std pat lookup using DIC, returns DFN
S AGPATDFN=$G(DFN) ;PHASE OUT USE OF DFN TO AVOID CHANGES WHEN CALLING DIC
D RESET^AUPNLKZ ; Set DUZ(2) back to original value
;G R1 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
L0 ;
K AG
G L1:'$D(DFN)
S AGPATDFN=DFN ;PHASE OUT USE OF DFN TO AVOID CHANGES WHEN CALLING DIC
G L0A:'$D(^AUPNPAT(DFN,41,DUZ(2)))
G L0C:$P(^AUPNPAT(DFN,41,DUZ(2),0),U,3)]""
I $D(AGDOG) D G VAR
. W !!,"This patient is already registered at this facility!"
. K DIR
. S DIR(0)="E"
. S DIR("T")=DTIME
. D ^DIR
. K DIR
I AGOPT(14)'="N",$D(^AUPNPAT(DFN,11)),$P(^AUPNPAT(DFN,11),U,12)]"" D
. D CALCELIG^AGBIC2
. W !,"This patient's eligibility is ",$P(AG("NARR1"),":",2)
K DIR
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("A")="Do you wish to edit "_$P(^DPT(DFN,0),U)_" (Y/N) "
S DIR("T")=DTIME
D ^DIR
G VAR:Y="^"
G END:$D(DTOUT)!(Y="/.,")!(Y="^^")
G L0D:Y=0!(Y="")
G:Y=1 ^AGED1
G L0
L0A ;
K DIR
S DIR(0)="Y"
S DIR("B")="YES"
S DIR("A")="Do you wish to register "_$P(^DPT(DFN,0),U)_" at "_$P(^DIC(4,DUZ(2),0),U)_" (Y/N) "
S DIR("T")=DTIME
D ^DIR
S AG("NEWREG")=""
G R2:Y="^"
G END:$D(DTOUT)!(Y="/.,")!(Y="^^")
I Y=1!(Y="") D G CHART1^AGMAN
. S AGPTPG=0
G VAR:Y=0
G L0A
L0C ;
I $D(AGDOG) W !!,"This patient is already registered at this facility but is inactive!" W !,"Refer to Medical Records for Reactivation" D READ^AG G VAR
W !!,"""",$P(^DPT(DFN,0),U),""" is filed as """,$S($P(^AUPNPAT(DFN,41,DUZ(2),0),U,5)="D":"DELETED",1:"INACTIVE"),""".",!!,"Do you wish to RE-ACTIVATE this patient's file? (Y/N) NO// " D READ^AG
G END:$D(DFOUT)!$D(DTOUT),VAR:$D(DUOUT)!(Y["N")!$D(DLOUT) S AG("EDIT")="" G C1^AGACT:Y["Y" D YN^AG G L0C
L0D ;
K DFN,AG("EDIT")
L1 ;EP
W !,"Enter the NEW PATIENT'S FULL NAME....."
W !," (EXAMPLE: MORGAN,JAMES PAUL,JR (no space after commas))"
W !!,"Entering NEW Patient for ",$P(^DIC(4,DUZ(2),0),U),!!
W:$D(DFN) $P(^DPT(DFN,0),U),"// "
W !!
S DIC("A")="Enter the PATIENT'S NAME: "
S DIC="^AUPNPAT("
S DIC(0)="AEMLQ"
S DIADD=1
S DLAYGO=2
D SET^AUPNLKZ
D ^DIC
D RESET^AUPNLKZ
K DIADD,DLAYGO,DIC
I $D(DUOUT)!($D(DTOUT))!(X="") G END
G:Y=-1 L1
S DFN=+Y
S AGPATDFN=DFN ;PHASE OUT USE OF DFN TO AVOID CHANGES WHEN CALLING DIC
;ADD LOCK SO PATIENT BEING EDITED CANNOT BE EDITED BY ANOTHER USER
L +^AUPNPAT(DFN):5 I '$T W !,"Patient's record already in use! Try again later!" Q
;L +^DPT(DFN):5 I '$T W !,"Patient's record already in use! Try again later!" Q ;AG*7.1*2
D NOW^%DTC
S AGDTS=%
S ^AGPATCH(AGDTS,DUZ(2),DFN)="NEW"
S $P(^AUPNPAT(DFN,0),U,11)=DUZ ; hard set is necessary as data item is uneditable per file definition
K AG("EDIT")
G ^AG2:AGOPT(14)="N" ;ELIGIBILITY AND TRIBAL DATA
G ^AGBIC2:AGOPT(14)="Y" ;MANDATORY DATA
G ^AGBIC2P:AGOPT(14)="C" ;MANDATORY DATA 2
;
L11 ;EP
I '$D(AGPAT) S AGPAT=$P(^DPT(DFN,0),U)
S AG("NPPADD")=""
NPPLOOP ;
D NPP^AGED11A
D ACK^AGED11A
D RHI^AGED11A
ETHNIC ;ENTER ETHNICITY
D ETHNIC^AGED10B ;AG*7.1*7/AG*7.1*8 - Changed to AGED10B
RACE ; ENTER RACE, NUMBER IN HOUSEHOLD, TOTAL HOUSEHOLD INCOME
D RACE^AGED10B ;AG*7.1*10 - Moved Race outside of check below
I AGOPT(22)="Y" D
. D NIH^AGED10B ;AG*7.1*8 - Changed to AGED10B
. D THI^AGED10B ;AG*7.1*8 - Changed to AGED10B
;
L -^AUPNPAT(DFN)
;L -^DPT(DFN) ;AG*7.1*2
W !!!,"This concludes the NEW PATIENT ENTRY PROCESS for this patient."
H 2
;
;BEGIN **MPI** ADD PATIENT TO MPI AG*7.2 IHS/SD/TPF 5/6/2010 ;MAYBE USE THE VTQ AS A QUERY 'SEEDER'
;D CREATMSG^AGMPIHLO(DFN,"VTQ",,.SUCCESS) ;IF SUCCESSFUL THEN MPI ICN HAS BEEN ADDED TO THE PATIENTS FILE
;I 'SUCCESS D
;.S AGERROR="MPI DFN="_DFN_" :: "_"ERROR WHEN CREATING VTQ EXACT MATCH QUERY"
;.D NOTIF^AGMPIHLO(DFN,AGERROR)
N X,SUCCESS,DIC,INDA
S X="AGMPIHLO" X ^%ZOSF("TEST") I $T D
.D CREATMSG^AGMPIHLO(DFN,"A28",,.SUCCESS)
.W !!,"A request to add this patient has been sent to the MPI" H 2
.I 'SUCCESS D NOTIF^AGMPIHLO(DFN,"Unable to create A28 to add patient to MPI from AGMPHLVQ")
.S X="AG REGISTER A PATIENT",DIC=101,INDA=DFN
.D EN^XQOR
;END **MPI**
;
;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
I $$AGE^AGUTILS(AGPATDFN)<3 D AUTOADD^BIPATE(AGPATDFN,DUZ(2),.AGERR,"")
;END NEW CODE
;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL
S ^XTMP("AGHL7",DUZ(2),DFN)=DFN ;AG*7.1*9 - Added DUZ(2) subscript
S ^XTMP("AGHL7AG",DUZ(2),DFN,"REGISTER")="" ;AG*7.1*9 - Added DUZ(2) subscript
Q
END ;
G K:$D(AG("EDIT"))
K AG,AGT,AGDTS
Q
K ;EP
W !!,*7,"The '",$P(^DPT(DFN,0),U),"' file is deleted."
D Z1^AGKPAT
D DFN^AGKPAT
G END
AG0 ; IHS/ASDS/EFG - Add a patient opening page ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**1,2,7,8,9,10**;AUG 25, 2005;Build 7
+2 ;
+3 KILL DOG,AGDOG
+4 ;
DOG ;PEP - From Other Systems.
+1 DO ^AGVAR
+2 ;renamespace external call variable
IF $DATA(DOG)
SET AGDOG=DOG
VAR ;
+1 IF $DATA(AGDOG)
WRITE @IOF,!,"ADD a new patient......"
+2 KILL AG,DFN
R1 ;
+1 IF $DATA(DFN)
GOTO L0
+2 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
+3 ;K DIR
+4 ;S DIR(0)="Y"
+5 ;S DIR("B")="YES"
+6 ;S DIR("A")="Do you wish to SCAN FOR SIMILAR NAMES or CHART NUMBERS? (Y/N) "
+7 ;S DIR("T")=DTIME
+8 ;D ^DIR
+9 ;Q:$D(DFOUT)!$D(DTOUT)!$D(DUOUT)
+10 ;G L0:Y=0
+11 ;G R2:Y=1!$D(DLOUT)
+12 ;G R1
+13 ;END IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
R2 ;
+1 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
WRITE !!,"You must first SCAN FOR SIMILAR NAMES or CHART NUMBERS NOW..."
+2 KILL DIC
+3 SET DIC("W")="D ^AGSCANP"
+4 ; Set DUZ(2) to 0
DO SET^AUPNLKZ
+5 ; Std pat lookup using DIC, returns DFN
DO PTLK^AG
+6 ;PHASE OUT USE OF DFN TO AVOID CHANGES WHEN CALLING DIC
SET AGPATDFN=$GET(DFN)
+7 ; Set DUZ(2) back to original value
DO RESET^AUPNLKZ
+8 ;G R1 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 13 PAGE 11
L0 ;
+1 KILL AG
+2 IF '$DATA(DFN)
GOTO L1
+3 ;PHASE OUT USE OF DFN TO AVOID CHANGES WHEN CALLING DIC
SET AGPATDFN=DFN
+4 IF '$DATA(^AUPNPAT(DFN,41,DUZ(2)))
GOTO L0A
+5 IF $PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,3)]""
GOTO L0C
+6 IF $DATA(AGDOG)
Begin DoDot:1
+7 WRITE !!,"This patient is already registered at this facility!"
+8 KILL DIR
+9 SET DIR(0)="E"
+10 SET DIR("T")=DTIME
+11 DO ^DIR
+12 KILL DIR
End DoDot:1
GOTO VAR
+13 IF AGOPT(14)'="N"
IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^AUPNPAT(DFN,11),U,12)]""
Begin DoDot:1
+14 DO CALCELIG^AGBIC2
+15 WRITE !,"This patient's eligibility is ",$PIECE(AG("NARR1"),":",2)
End DoDot:1
+16 KILL DIR
+17 SET DIR(0)="Y"
+18 SET DIR("B")="NO"
+19 SET DIR("A")="Do you wish to edit "_$PIECE(^DPT(DFN,0),U)_" (Y/N) "
+20 SET DIR("T")=DTIME
+21 DO ^DIR
+22 IF Y="^"
GOTO VAR
+23 IF $DATA(DTOUT)!(Y="/.,")!(Y="^^")
GOTO END
+24 IF Y=0!(Y="")
GOTO L0D
+25 IF Y=1
GOTO ^AGED1
+26 GOTO L0
L0A ;
+1 KILL DIR
+2 SET DIR(0)="Y"
+3 SET DIR("B")="YES"
+4 SET DIR("A")="Do you wish to register "_$PIECE(^DPT(DFN,0),U)_" at "_$PIECE(^DIC(4,DUZ(2),0),U)_" (Y/N) "
+5 SET DIR("T")=DTIME
+6 DO ^DIR
+7 SET AG("NEWREG")=""
+8 IF Y="^"
GOTO R2
+9 IF $DATA(DTOUT)!(Y="/.,")!(Y="^^")
GOTO END
+10 IF Y=1!(Y="")
Begin DoDot:1
+11 SET AGPTPG=0
End DoDot:1
GOTO CHART1^AGMAN
+12 IF Y=0
GOTO VAR
+13 GOTO L0A
L0C ;
+1 IF $DATA(AGDOG)
WRITE !!,"This patient is already registered at this facility but is inactive!"
WRITE !,"Refer to Medical Records for Reactivation"
DO READ^AG
GOTO VAR
+2 WRITE !!,"""",$PIECE(^DPT(DFN,0),U),""" is filed as """,$SELECT($PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,5)="D":"DELETED",1:"INACTIVE"),""".",!!,"Do you wish to RE-ACTIVATE this patient's file? (Y/N) NO// "
DO READ^AG
+3 IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)!(Y["N")!$DATA(DLOUT)
GOTO VAR
SET AG("EDIT")=""
IF Y["Y"
GOTO C1^AGACT
DO YN^AG
GOTO L0C
L0D ;
+1 KILL DFN,AG("EDIT")
L1 ;EP
+1 WRITE !,"Enter the NEW PATIENT'S FULL NAME....."
+2 WRITE !," (EXAMPLE: MORGAN,JAMES PAUL,JR (no space after commas))"
+3 WRITE !!,"Entering NEW Patient for ",$PIECE(^DIC(4,DUZ(2),0),U),!!
+4 IF $DATA(DFN)
WRITE $PIECE(^DPT(DFN,0),U),"// "
+5 WRITE !!
+6 SET DIC("A")="Enter the PATIENT'S NAME: "
+7 SET DIC="^AUPNPAT("
+8 SET DIC(0)="AEMLQ"
+9 SET DIADD=1
+10 SET DLAYGO=2
+11 DO SET^AUPNLKZ
+12 DO ^DIC
+13 DO RESET^AUPNLKZ
+14 KILL DIADD,DLAYGO,DIC
+15 IF $DATA(DUOUT)!($DATA(DTOUT))!(X="")
GOTO END
+16 IF Y=-1
GOTO L1
+17 SET DFN=+Y
+18 ;PHASE OUT USE OF DFN TO AVOID CHANGES WHEN CALLING DIC
SET AGPATDFN=DFN
+19 ;ADD LOCK SO PATIENT BEING EDITED CANNOT BE EDITED BY ANOTHER USER
+20 LOCK +^AUPNPAT(DFN):5
IF '$TEST
WRITE !,"Patient's record already in use! Try again later!"
QUIT
+21 ;L +^DPT(DFN):5 I '$T W !,"Patient's record already in use! Try again later!" Q ;AG*7.1*2
+22 DO NOW^%DTC
+23 SET AGDTS=%
+24 SET ^AGPATCH(AGDTS,DUZ(2),DFN)="NEW"
+25 ; hard set is necessary as data item is uneditable per file definition
SET $PIECE(^AUPNPAT(DFN,0),U,11)=DUZ
+26 KILL AG("EDIT")
+27 ;ELIGIBILITY AND TRIBAL DATA
IF AGOPT(14)="N"
GOTO ^AG2
+28 ;MANDATORY DATA
IF AGOPT(14)="Y"
GOTO ^AGBIC2
+29 ;MANDATORY DATA 2
IF AGOPT(14)="C"
GOTO ^AGBIC2P
+30 ;
L11 ;EP
+1 IF '$DATA(AGPAT)
SET AGPAT=$PIECE(^DPT(DFN,0),U)
+2 SET AG("NPPADD")=""
NPPLOOP ;
+1 DO NPP^AGED11A
+2 DO ACK^AGED11A
+3 DO RHI^AGED11A
ETHNIC ;ENTER ETHNICITY
+1 ;AG*7.1*7/AG*7.1*8 - Changed to AGED10B
DO ETHNIC^AGED10B
RACE ; ENTER RACE, NUMBER IN HOUSEHOLD, TOTAL HOUSEHOLD INCOME
+1 ;AG*7.1*10 - Moved Race outside of check below
DO RACE^AGED10B
+2 IF AGOPT(22)="Y"
Begin DoDot:1
+3 ;AG*7.1*8 - Changed to AGED10B
DO NIH^AGED10B
+4 ;AG*7.1*8 - Changed to AGED10B
DO THI^AGED10B
End DoDot:1
+5 ;
+6 LOCK -^AUPNPAT(DFN)
+7 ;L -^DPT(DFN) ;AG*7.1*2
+8 WRITE !!!,"This concludes the NEW PATIENT ENTRY PROCESS for this patient."
+9 HANG 2
+10 ;
+11 ;BEGIN **MPI** ADD PATIENT TO MPI AG*7.2 IHS/SD/TPF 5/6/2010 ;MAYBE USE THE VTQ AS A QUERY 'SEEDER'
+12 ;D CREATMSG^AGMPIHLO(DFN,"VTQ",,.SUCCESS) ;IF SUCCESSFUL THEN MPI ICN HAS BEEN ADDED TO THE PATIENTS FILE
+13 ;I 'SUCCESS D
+14 ;.S AGERROR="MPI DFN="_DFN_" :: "_"ERROR WHEN CREATING VTQ EXACT MATCH QUERY"
+15 ;.D NOTIF^AGMPIHLO(DFN,AGERROR)
+16 NEW X,SUCCESS,DIC,INDA
+17 SET X="AGMPIHLO"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+18 DO CREATMSG^AGMPIHLO(DFN,"A28",,.SUCCESS)
+19 WRITE !!,"A request to add this patient has been sent to the MPI"
HANG 2
+20 IF 'SUCCESS
DO NOTIF^AGMPIHLO(DFN,"Unable to create A28 to add patient to MPI from AGMPHLVQ")
+21 SET X="AG REGISTER A PATIENT"
SET DIC=101
SET INDA=DFN
+22 DO EN^XQOR
End DoDot:1
+23 ;END **MPI**
+24 ;
+25 ;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
+26 IF $$AGE^AGUTILS(AGPATDFN)<3
DO AUTOADD^BIPATE(AGPATDFN,DUZ(2),.AGERR,"")
+27 ;END NEW CODE
+28 ;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL
+29 ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7",DUZ(2),DFN)=DFN
+30 ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7AG",DUZ(2),DFN,"REGISTER")=""
+31 QUIT
END ;
+1 IF $DATA(AG("EDIT"))
GOTO K
+2 KILL AG,AGT,AGDTS
+3 QUIT
K ;EP
+1 WRITE !!,*7,"The '",$PIECE(^DPT(DFN,0),U),"' file is deleted."
+2 DO Z1^AGKPAT
+3 DO DFN^AGKPAT
+4 GOTO END
