DGREG ;ALB/JDS,MRL,PJR,PHH,ARF,RN,JAM,ARF - REGISTER PATIENT ; 3/28/14 12:38pm
;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,864,886,915,926,1024,993,1040,1027,1045,1067,1075,1102,1111**;Aug 13, 1993;Build 18
;
; DG*5.3*1075 - Fix line 1 for SAC compliance
; Reference to (#350.9,54.01) supported by ICR #7429
; Reference to BACKGND^IBCNRDV supported by ICR #4288
;
START ;
EN D LO^DGUTL S DGCLPR=""
N DGDIV
S DGDIV=$$PRIM^VASITE
S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1)
I $P(^DG(43,1,0),U,39) S %ZIS="NQ",%ZIS("A")="Select 1010 printer: " D ^%ZIS Q:POP S (DGIO(10),DGIO("PRF"),DGIO("RT"),DGIO("HS"))=ION,DGASKDEV="" I $E(IOST,1,2)'["P-" W !,$C(7),"Not a printer" G DGREG
K %ZIS("B")
I '$D(DGIO),$P(^DG(43,1,0),U,30) S %ZIS="N",IOP="HOME" D ^%ZIS I $D(IOS),IOS,$D(^%ZIS(1,+IOS,99)),$D(^%ZIS(1,+^(99),0)) S Y=$P(^(0),U,1) W !,"Using closest printer ",Y,! F I=10,"PRF","RT","HS" S DGIO(I)=Y
A D ENDREG($G(DFN))
; DG*5.3*1040 - NEW variable DGTMOT and initialize to 0 to track timeout in address and DGADDRE to track the return value of $$ADD^DGADDUTL
N DGADDRE,DGTMOT S DGTMOT=0,DGADDRE=""
N DGNEWP ;**1024 USING DGNEWP INSTEAD OF JUST DGNEWP TO AVOID Y BEING RESET ON US
W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$G(DGNEWP) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP
;
;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1)
I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A
;
D CIRN
;
I +$G(DGNEW) D
. ; query CMOR for Patient Record Flag Assignments if NEW patient and
. ; display results.
. I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
. I $$EN^DGPFMPI(DFN)
;
D ROMQRY
;
; DG*5.3*993 The DO YOU WISH TO ENROLL, ENROLLMENT DATE, and DO YOU WANT AN APPT questions
; were moved here from the end of patient registration. Also, if the patient does not wish to enroll
; a REGISTRATION REASON question will be asked
N DGBACK,DGENRDT,DGENRIEN,DGENRRSN,DGENRYN,DGERR,DGEXIT,DGFDA,DGFDD,DGIEN,DGNOW,DGOUT,DGSTA,DGVET,DGX,DGY,DIE,DIR,DR,DTOUT,DUOUT
; Do you wish to enroll?
S DGBACK=0,DGSTA="",DGIEN=$$FINDCUR^DGENA(DFN) I DGIEN S DGSTA=$$GET1^DIQ(27.11,DGIEN_",",.04)
K DGOUT D GETS^DIQ(2,DFN_",",".3216*","I","DGOUT")
S DGFDD=0,DGX="" F S DGX=$O(DGOUT(2.3216,DGX),-1) Q:DGX="" S DGFDD=+$G(DGOUT(2.3216,DGX,.08)) Q:DGFDD ;DGFDD=Future Discharge Date
ENRYN S DGBACK=0,DGENRYN="",DGVET=$$VET^DGENPTA(DFN) S:'DGVET DGENRYN=0
; DG*5.3*1045 - Newed DGINELIG,DGENPTA,DGIPTAPPLD variables
N STATUS,DGPREXST,DGPTAPPLD,DGCURR,DGKEY,DGREQNAME,DGENSTAT,DGWSHTOEN,DGRESP,DGDEATH,DGDEAD,DGSHWPRMPT,DGNOENRLL,DGINELIG,DGENPTA,DGIPTAPPLD ; DG*5.3*1027 - Newed E&E Webservice variables
I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE")) ;DG*5.3*1045 Below two lines have logic for Ineligible Date
S DGDEAD=0,DGIPTAPPLD=""
S DGDEATH=$$DEATH^DGENPTA(DFN) I DGDEATH'=0 S DGDEAD=1
S DGPTAPPLD="",DGPREXST="",DGPREXST=$$PREEXIST(DFN),STATUS="",STATUS=$$STATUS^DGENA($G(DFN)) I STATUS=25 S DGENRYN=0,DGPREXST=0
S DGCURR="",DGCURR=$$FINDCUR^DGENA(DFN) I DGCURR S DGPTAPPLD=$$GET1^DIQ(27.11,DGCURR_",",.14,"I")
I DGPTAPPLD=1 S DGENRYN=1
I $G(DGINELIG)'="",$G(DGPTAPPLD)="" S DGIPTAPPLD=$$GET1^DIQ(2,DFN,27.04,"I") ;DG*5.3*1045 Below two lines have logic for Ineligible Date
I $G(DGIPTAPPLD)=1 S DGENRYN=1
; DG*5.3*1027 Display DO YOU WISH TO ENROLL Prompt if Veteran AND
; PT APPLIED FOR ENROLLMENT in the Patient Enrollment file is NO
; There is NO Patient Enrollment record and The patient is unknown to ES
; Supported DBIA #2701: The supported DBIA is used to access MPI
; APIs to retrieve ICN, determine if ICN
; is local and if site is LST.
; Supported ICRs
; #3356 - XQY0 ; Kernel Variable
K ^TMP($J,"DGOLDVET")
; The ^TMP global is cleaned up in DG REGISTER PATIENT option EXIT ACTION
S ^TMP($J,"DGOLDVET",DFN)=DGVET
S DGKEY=$$GETICN^MPIF001(DFN)
S DGREQNAME="VistAData"
S DGRESP=0,DGSHWPRMPT=0,DGNOENRLL=0
I $P(DGKEY,"^",1)'=-1 S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
I '$$FINDCUR^DGENA(DFN),+DGRESP=0 S DGNOENRLL=1
I ((DGNOENRLL=1)!($G(DGPTAPPLD)=0)) S DGSHWPRMPT=1 ; DG*5.3*1027 Modified DGPTAPPLD=0 per RSD
I 'DGFDD,'DGDEAD,DGVET,DGSHWPRMPT F D Q:DGENRYN'=""!(DGBACK)
. K DIR,DTOUT I ($G(DGPTAPPLD)=0) S DIR("B")="NO"
. S DIR(0)="Y",DIR("A")="DO YOU WISH TO ENROLL"
. S DIR("?")="Select Y or YES if the patient wants to apply for enrollment for VHA Healthcare benefits. Select N or NO if the patient only wants to register without applying for enrollment."
. S DIR("??")="^D HELPENR^DGREG"
. D ^DIR
. I ($G(DGPTAPPLD)="")&((X["Y")!(X["y")) D Q
. . S DGENRYN=1
. . N DGFDA,DGIENS,DGRSLT
. . S DGRSLT=DGENRYN,DGIENS=DFN_",",DGFDA(2,DGIENS,27.04)=DGRSLT
. . D FILE^DIE("","DGFDA")
. I ($G(DGPTAPPLD)="")&(X["N")!(X["n") S DGENRYN=0 D Q
. . S DGENRYN=0
. . N DGFDA,DGIENS,DGRSLT
. . S DGRSLT=DGENRYN,DGIENS=DFN_",",DGFDA(2,DGIENS,27.04)=DGRSLT
. . D FILE^DIE("","DGFDA") ;DG*5.3*1027
. . I $P($G(XQY0),"^",1)="DG REGISTER PATIENT",$G(DGENRYN)=0,$$GET1^DIQ(2,DFN,1010.1512,"I")=1 D APPTCHG^DGRPC ; DG*5.3*1027 Remove appointmnet request data when DGENRYN is changed from Y to N (DGPTAPPLD)=1
. I ($G(DGPTAPPLD)=0)&(X["Y")!(X["y") W !!?5,"This is an existing patient. To complete the enrollment" W !?5,"application process, please use the Enrollment System."
. I ($G(DGPTAPPLD)=0)&(X["Y")!(X["y") W !!!?5,"Press <Enter> to Continue or '^' to exit:" R X:DTIME
. S:$D(DTOUT)!(X=U) DGBACK=1
G:DGBACK A
S:DGFDD DGENRYN=1
S DGENRRSN="",DGNOW=$$NOW^XLFDT()
;I (DGENRYN=0)&('DGPREXST) D G:DGENRRSN="^" ENRYN ; Check this condition for prexist from DG 993
I (DGENRYN=0) D G:DGENRRSN="^" ENRYN
. ;REGISTRATION ONLY REASON
. S DGY="",DGX=$$FINDCUR^DGENA(DFN) I DGX?1.N S DGY=$$GET1^DIQ(27.11,DGX_",",.15)
. I (DGY=""),(STATUS=""),+DGRESP=0 D ; DG*5.3*1027 Unknown to ES condition added
. . ;W !,"SELF-REPORTED REGISTRATION ONLY REASON" ;DG*5.3*1027 - not needed - replaced with code below
. . W ! ;DG*5.3*1027 place a line in between prompts
. . F D Q:(DGENRRSN="^")!(DGENRRSN)
. . . ; DG*5.3*1027 - Modification of the data entry to field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
. . . K DIR
. . . S DIR(0)="27.11,.15,AO"
. . . S DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
. . . D ^DIR
. . . I $D(DTOUT)!$D(DUOUT) S DGENRRSN="^" Q
. . . S DGENRRSN=+Y
. . . I 'DGENRRSN W !,"This is a required field.",! Q
. . . S DGENRODT=DGNOW,DGENSRCE=1 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration
N DGBACK,DGENRDTT,ANS,DGAPLDT,DGENRIEN
S DGENRIEN=$$FINDCUR^DGENA(DFN)
S DGBACK=0,DGAPLDT=$$GET1^DIQ(27.11,DGENRIEN_",",.01,"I")
I (DGENRYN=1) S DGEXIT=0 D G:DGEXIT ENRYN
. ;ENROLLMENT APPLICATION DATE
. ; Do not display the Application Prompt if application date exists in 27.11 file
. ; and do not display APPOINTMENT REQUEST IN 1010EZ prompt
. K Y I $G(DGAPLDT)="" D PROMPT^DGENU(27.11,.01,"NOW",,1,1) S:$E(Y)="^" DGEXIT=1 Q:DGEXIT D
. . S DGENRDTT=Y S:Y?1.N.E DGENRDT=Y\1 S:Y="" DGENRDT=DGNOW\1,DGENRDTT=DGNOW
. . ; If no value for APPT REQUEST, prompt for it
. . I $P($G(^DPT(DFN,1010.15)),"^",9)="" D APPTREQ(DGENRDTT,.DGBACK)
. S DGY="",DGX=$$FINDCUR^DGENA(DFN) S:DGX?1.N DGY=$$GET1^DIQ(27.11,DGX_",",.16) I DGY="" D
. . S DGENRRSN="",DGENRODT=DGNOW,DGENSRCE=1 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration
;
G:DGBACK ENRYN
; END OF DG*5.3*993 mods
S (DGFC,CURR)=0
D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
S %ZIS="N",IOP="HOME" D ^%ZIS S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) D ENDREG($G(DFN)) D HL7A08^VAFCDD01 K DFN,DGRPOUT G A
D HINQ^DG10
;I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3;DG*5.3*1111-remove Select Admitting Area
D REG^IVMCQ($G(DFN)) ; send financial query
G A1
;
;
APPTREQ(DGENRDTT,DGBACK) ; Prompt for DO YOU WANT AN APPT. WITH A VA DOCTOR/PROVIDER AS SOON AS AVAILABLE?
; If YES, update fields #2,#1010.159 and #2,#1010.1511 (NOTE: This code came from DGEN)
; Input: DGENRDTT - value for ENROLLMENT APPLICATION DATE field 1010.1511 in PATIENT file
; Output: DGBACK (Pass by Reference) - If set, the user has exited from the prompt
;
N DGSXS,DGAPPTAN,DA,DR,DIE
S DGSXS="",DGBACK=0
S DGSXS=$$PROMPT^DGENU(2,1010.159,1,.DGAPPTAN,"",1)
I 'DGSXS S DGBACK=1 Q
S DA=DFN
S DIE="^DPT("
S DR="1010.159///^S X=DGAPPTAN"
D ^DIE
K DA,DR,DIE
; If patient answered YES to "Do you want an appt" question, set APPOINTMENT REQUEST DATE to DGENRDTT
I DGAPPTAN D
. S DIE="^DPT("
. S DA=DFN
. S DGENRDTT=$$HLDATE^HLFNC(DGENRDTT,"DT")
. S DR="1010.1511///^S X=DGENRDTT"
. D ^DIE
; If patient answered NO to "Do you want an appt" question set APPOINTMENT REQUEST DATE to TODAY
I DGAPPTAN=0 D
. S DIE="^DPT("
. S DA=DFN
. S DR="1010.1511///^S X=DT"
. D ^DIE
Q
;
PREEXIST(DFN) ;DG*5.3*993 - Did this patient exist before the installation of DG*5.3*993
N DGX,DGINST,DGINSTAT,DGINSTID,DGICN,DGEXIST,DGARR,DGREC,DGESKNOWN,I
S (DGEXIST,DGICN)=""
S DGICN=+($$GETICN^MPIF001(DFN))
I DGICN=-1 Q 0
K DGARR I DGICN'=-1 S DGEXIST=$$QUERYTF^VAFCTFU1(DGICN,"DGARR","") ; check Treating Facility returns 1^text if not found
I $P(DGEXIST,"^",1)=1 Q 0
S DGX=0,DGESKNOWN=0,I=0,DGREC="",DGINSTID="" F I=1:1 Q:'$D(DGARR(I)) S DGREC=DGARR(I) D Q:DGESKNOWN=1
. S DGINSTAT="",DGINST=$P(DGREC,"^",1)
. S DGINSTID=$P($G(^DIC(4,DGINST,9999,1,0)),"^",2) I DGINSTID="200ESR" S DGINSTAT=$$GET1^DIQ(4,DGINST_",",99)
. I (DGINSTID="200ESR")&(DGINSTAT="200ESR") S DGESKNOWN=1
I (DGESKNOWN=1) S DGX=1 ;if exist to ES and applied="" it preexist
I (DGESKNOWN=0)&(DGEXIST'=0) S DGX=0 ;not known to ES and not in treating facility (new record)
I (DGESKNOWN=0)&(DGEXIST="") S DGX=0 ;new record
Q DGX
;
HELPENR ;DG*5.3*993 - Help for ?? on the DO YOU WISH TO ENROLL? question
W !,"Select Y or YES if the patient wants to apply for enrollment for VHA"
W !,"Healthcare benefits. Select N or NO if the patient only wants to"
W !,"register without applying for enrollment."
Q
;
REASON(Y,XQY0) ; DG*5.3*1027 - Screen logic/Input Transform for field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
; Input: Y - Entry to be checked
; XQYO - String containing the option that is being run (may be null when accessing the field from Fileman)
; Returns: TRUE if the entry Y is valid
;
; Supported ICRs:
; Reference to variable XQY0 supported by ICR #3356 ; Kernel Variable
; Reference to $$GET^XPAR supported by ICR #2263
; Reference to $$GET1^DIQ() supported by ICR #2056
;
; Check the entry in the 408.43 (PATIENT REGISTRATION ONLY REASON) dictionary
I '$D(^DG(408.43,Y,0)) Q 0
; Entries with AVAILABILITY field = 3 are not valid
I $P(^DG(408.43,Y,0),U,2)=3 Q 0
; DG*5.3*1067 - For Reg Only Reasons added in patch 1067, screen them out until the date/time in XPAR parameter DG PATCH DG*5.3*1067 ACTIVE is reached
N DGREASON,DGACTTS
S DGREASON=$$GET1^DIQ(408.43,Y_",",.01)
I DGREASON="CLINICAL EVALUATION"!(DGREASON="4TH MISSION")!(DGREASON="HUD-VASH")!(DGREASON="IMMUNIZATIONS") D I $$NOW^XLFDT()<DGACTTS Q 0
. ; Get the timestamp stored in the parameter
. S DGACTTS=$$GET^XPAR("PKG","DG PATCH DG*5.3*1067 ACTIVE",1)
; Handle the condition where not within a Vista option or in Programmer mode, default to 0
I $G(XQY0)=""!($P($G(XQY0),U,1)="XUPROGMODE") N DGRET S DGRET=0 D Q DGRET
. ; If direct call to DG COLLATERAL, Only entries with AVAILABILITY field = 2 (COLLATERAL) are valid (variable DR set in ^DGCOL)
. I $G(DR)="[DGCOLLATERAL]" I $P(^DG(408.43,Y,0),U,2)=2 S DGRET=1
; XQY0 is defined and is not Programmer mode:
; DG*5.3*1067; If non-Veteran, do not allow CLINICAL EVALUATION
N DGVET
S DGVET=$$VET1^DGENPTA($G(DFN))
I 'DGVET,DGREASON="CLINICAL EVALUATION" Q 0
; If not in DG COLLATERAL PATIENT option, all other entries are valid
I $P(XQY0,U,1)'="DG COLLATERAL PATIENT" Q 1
; Otherwise, in DG COLLATERAL PATIENT option, only entries with AVAILABILITY field = 2 (COLLATERAL) are valid
I $P(^DG(408.43,Y,0),U,2)=2 Q 1
Q 0
;
PAUSE ;
N DIR
S DIR(0)="E" D ^DIR
Q
;
RT ;I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3 ;DG*5.3*1111-remove Select Admitting Area from Register a Patient
Q
;
; DG*5.3*1040 - If variable DGADDRE=-1, branch to Q due to timeout; if DGRPOUT=1, branch to Q as well
A1 W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" S %=1 D YN^DICN D G:$G(DGADDRE)=-1 Q G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G:+$G(DGRPOUT) Q G Q:'$D(DA)
.I +$G(DGNEW) Q
.S DGADDRE=$$ADD^DGADDUTL($G(DFN)) ; DG*5.3*1040 - Store the return value in DGADDRE
G CH
;DG*5.3*1111 - Remove Is the patient currently being followed in a clinic for the same condition from Register a Patient process
PR G ABIL ;W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1
;I '% W !?4,$C(7),"Enter 'Y' if the patient is being followed in clinic for condition for which",!?6,"registered, 'N' if not." G PR
;S CURR=% G SEEN
; Killing ^TMP($J,"DGOLDVET",DFN) below ; DG*5.3*1027 cleaning the temp global
CK S DGEDCN=1 D ^DGRPC
CH S X=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0),X1=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0) I 'X,'X1 G CH1
CH1 K ^TMP($J,"DGOLDVET",DFN) S DA=DFN G PR:'$D(^DPT("ADA",1,DA)) W !!,"There is still an open disposition--register aborted.",$C(7),$C(7) G Q
;DG*5.3*1111 - remove Is the patient to be examined in the medical center today from Register a Patient process
SEEN ;W !!,"Is the patient to be examined in the medical center today" S %=1 D YN^DICN S SEEN=% G:%<0 Q I %'>0 W !!,"Enter 'Y' if the patient is to be examined today, 'N' if not.",$C(7) G SEEN
ABIL D ^DGREGG
ENR ; next line appears to be dead code. left commented just to test. mli 4/28/94
;S DE=0 F I=0:0 S I=$O(^DPT(DA,"DE",I)) Q:'I I $P(^(I,0),"^",3)'?7N Q D PR:'DE S L=+$P($S($D(^SC(L,0)):^(0),1:""),"^",1)
REG S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// "
W !,%DT("A") R ANS:DTIME S:'$T ANS="^" S:ANS="" ANS="N" S X=ANS G Q:ANS="^" S DA(1)=DFN D CHK^DIE(2.101,.01,"E",X,.RESULT) G REG:RESULT="^"!('$D(RESULT)),PR3:'(RESULT#1) S Y=RESULT
I (RESULT'="^") W " ("_RESULT(0)_")"
S DINUM=9999999-RESULT
S (DFN1,Y1)=DINUM,APD=Y I $D(^DPT(DFN,"DIS",Y1)) W !!,"You must enter a date that does not exist.",$C(7),$C(7) G REG
;patch 886 changed to incremental lock and dilocktm
G:$D(^DPT("ADA",1,DA)) CH1 L +@(DIE_DINUM_")"):$G(DILOCKTM,3) G:'$T MSG S:'($D(^DPT(DA(1),"DIS",0))#2) ^(0)="^2.101D^^" S DIC(0)="L",X=+Y D ^DIC
;
;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT
S VAFCDDT=X
; DG*5.3*993 Decoupling project code for register only
N DGSTUS,DGCHK
S DGCHK=0
S DGSTUS=$$STATUS^DGENA($G(DFN)) I DGSTUS=25 S DGCHK=1,DGENRYN=0 ; If DGSTUS=25 patient is Register Only ;27.11 TEST
S DGENRYN=$G(DGENRYN) I DGENRYN=0 S DGCHK=1 ;DG*5.3*993 If DGENRYN=1 patient said YES to enroll
;DG*5.3*1111-Comments in COMMENTS^DGREG0
N DA,SP
S DA=DFN1,DIE("NO^")=""
S DA(1)=DFN,DP=2.101
S DR="3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
;patch 886 changed lock to use dilocktm
D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:$G(DILOCKTM,3) G:'$T MSG D ^DIE L -@DGNDLOCK
I $D(DTOUT) D G Q
.K DTOUT
.N DA,DIK
.S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS"","
.D ^DIK
.W !!?5,"User Time-out. Required registration data could be missing."
.W !,?5,"This registration has been deleted."
; check whether facility applying to (division) is inactive
I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT
ASKDIV W !!?5,"The facility chosen either has no pointer to an Institution"
W !?5,"file record or the Institution file record is inactive."
W !?5,"Please choose another division."
S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE
I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV
CONT ; continue
S DGXXXD=1 D EL^DGREGE I $P(^DPT(DFN,"DIS",DFN1,0),"^",3)=4 S DA=DFN,DIE="^DPT(",DR=".368;.369" D ^DIE S DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DA=DFN1
;S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^") ;DG*5.3*1111 - The DGREG input template prompts grouping is removed
I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE
G ^DGREG0
PR2 W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG
PR3 W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG
H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1
; DG*5.3*1040 - Cleanup variable DGTMOT
Q K DG,DQ,DGTMOT G Q1^DGREG0
Q1 K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q
EL S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q
S DR=DR_"HUMANITARIAN EMERGENCY" Q
FEE S DGRPFEE=1 D DGREG K DGRPFEE G Q1
;
WARN I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2
I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2
Q
MSG W !,"Another user is editing, try later ..." G Q
;
BEGINREG(DFN) ;
N DGQRY
;Description: This is called at the beginning of the registration process.
;Concurrent processes can check the lock to determine if the patient is
;currently being registered.
;
Q:'$G(DFN) 0
; **915, check to see if a query was done within the last 5 minutes so we don't send again
S DGQRY=$$GET^DGENQRY($$FINDLAST^DGENQRY($G(DFN)),.DGQRY)
I $$FMDIFF^XLFDT($$NOW^XLFDT,$G(DGQRY("SENT")),2)>300,$$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!!
;patch 886 changed lock to use dilocktm
L +^TMP(DFN,"REGISTRATION IN PROGRESS"):$G(DILOCKTM,3)
I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record
Q
;
ENDREG(DFN) ;
;Description: releases the lock obtained by calling BEGINREG.
;
Q:'$G(DFN)
L -^TMP(DFN,"REGISTRATION IN PROGRESS")
D UNLOCK^DGENPTA1(DFN)
Q
;
IFREG(DFN) ;
;Description: tests whether the lock set by BEGINREG is set
;
;Input: DFN
;Output:
; Function Value = 1 if lock is set, 0 otherwise
;
N RETURN
Q:'$G(DFN) 0
;patch 886 changed lock to use dilocktm
L +^TMP(DFN,"REGISTRATION IN PROGRESS"):$G(DILOCKTM,3)
S RETURN='$T
L -^TMP(DFN,"REGISTRATION IN PROGRESS")
Q RETURN
Q
CIRN ;MPI QUERY
;check to see if CIRN PD/MPI is installed
N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T
K MPIFRTN
D MPIQ^MPIFAPI(DFN)
K MPIFRTN
Q
ROMQRY ;**926 TRIGGER IB INSURANCE QUERY
N ZTSAVE,A,ZTRTN,ZTDESC,ZTIO,ZTDTH,DGMSG
;Invoke IB Insurance Query (Query was introduced with IB*2.0*214)
;DG*1102/TAZ - Check Insurance Import Enabled flag
; Reference to Field 54.01 in File 350.9 supported by ICR #7429
I '$$GET1^DIQ(350.9,"1,",54.01,"I") D Q
. S DGMSG(1)="Insurance data retrieval is not currently enabled."
. S DGMSG(2)=" " D EN^DDIOL(.DGMSG) R A:5
S ZTSAVE("IBTYPE")=1,ZTSAVE("DFN")=DFN,ZTSAVE("IBDUZ")=$G(DUZ)
; Reference to BACKGND^IBCNRDV supported by ICR #4288
S ZTRTN="BACKGND^IBCNRDV",ZTDTH=$H,ZTDESC="IBCN INSURANCE QUERY TASK",ZTIO=""
D ^%ZTLOAD
;display busy message to interactive users
S DGMSG(1)="Insurance data retrieval has been initiated."
S DGMSG(2)=" " D EN^DDIOL(.DGMSG)
;**915 all "register once" functionality eliminated additional
; checks that use to be below this line.
Q ;**915 all register once functionality no longer executed and removed
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGREG 19907 printed Dec 13, 2024@02:54:48 Page 2
DGREG ;ALB/JDS,MRL,PJR,PHH,ARF,RN,JAM,ARF - REGISTER PATIENT ; 3/28/14 12:38pm
+1 ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,864,886,915,926,1024,993,1040,1027,1045,1067,1075,1102,1111**;Aug 13, 1993;Build 18
+2 ;
+3 ; DG*5.3*1075 - Fix line 1 for SAC compliance
+4 ; Reference to (#350.9,54.01) supported by ICR #7429
+5 ; Reference to BACKGND^IBCNRDV supported by ICR #4288
+6 ;
START ;
EN DO LO^DGUTL
SET DGCLPR=""
+1 NEW DGDIV
+2 SET DGDIV=$$PRIM^VASITE
+3 if DGDIV
SET %ZIS("B")=$PIECE($GET(^DG(40.8,+DGDIV,"DEV")),U,1)
+4 IF $PIECE(^DG(43,1,0),U,39)
SET %ZIS="NQ"
SET %ZIS("A")="Select 1010 printer: "
DO ^%ZIS
if POP
QUIT
SET (DGIO(10),DGIO("PRF"),DGIO("RT"),DGIO("HS"))=ION
SET DGASKDEV=""
IF $EXTRACT(IOST,1,2)'["P-"
WRITE !,$CHAR(7),"Not a printer"
GOTO DGREG
+5 KILL %ZIS("B")
+6 IF '$DATA(DGIO)
IF $PIECE(^DG(43,1,0),U,30)
SET %ZIS="N"
SET IOP="HOME"
DO ^%ZIS
IF $DATA(IOS)
IF IOS
IF $DATA(^%ZIS(1,+IOS,99))
IF $DATA(^%ZIS(1,+^(99),0))
SET Y=$PIECE(^(0),U,1)
WRITE !,"Using closest printer ",Y,!
FOR I=10,"PRF","RT","HS"
SET DGIO(I)=Y
A DO ENDREG($GET(DFN))
+1 ; DG*5.3*1040 - NEW variable DGTMOT and initialize to 0 to track timeout in address and DGADDRE to track the return value of $$ADD^DGADDUTL
+2 NEW DGADDRE,DGTMOT
SET DGTMOT=0
SET DGADDRE=""
+3 ;**1024 USING DGNEWP INSTEAD OF JUST DGNEWP TO AVOID Y BEING RESET ON US
NEW DGNEWP
+4 WRITE !!
SET DIC=2
SET DIC(0)="ALEQM"
SET DLAYGO=2
KILL DIC("S"),DIC("B")
DO ^DIC
KILL DLAYGO
if Y<0
GOTO Q1
SET (DFN,DA)=+Y
SET DGNEW=$GET(DGNEWP)
NEW Y
DO PAUSE^DG10
DO BEGINREG(DFN)
IF DGNEW
DO NEW^DGRP
+5 ;
+6 ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
+7 SET DOD=""
IF $GET(DFN)
SET DOD=$PIECE($GET(^DPT(DFN,.35)),"^",1)
+8 IF DOD
SET Y=DOD
SET DGPME=0
DO DIED^DGPMV
IF DGPME
KILL DFN,DGRPOUT
GOTO A
+9 ;
+10 DO CIRN
+11 ;
+12 IF +$GET(DGNEW)
Begin DoDot:1
+13 ; query CMOR for Patient Record Flag Assignments if NEW patient and
+14 ; display results.
+15 IF $$PRFQRY^DGPFAPI(DFN)
DO DISPPRF^DGPFAPI(DFN)
+16 IF $$EN^DGPFMPI(DFN)
End DoDot:1
+17 ;
+18 DO ROMQRY
+19 ;
+20 ; DG*5.3*993 The DO YOU WISH TO ENROLL, ENROLLMENT DATE, and DO YOU WANT AN APPT questions
+21 ; were moved here from the end of patient registration. Also, if the patient does not wish to enroll
+22 ; a REGISTRATION REASON question will be asked
+23 NEW DGBACK,DGENRDT,DGENRIEN,DGENRRSN,DGENRYN,DGERR,DGEXIT,DGFDA,DGFDD,DGIEN,DGNOW,DGOUT,DGSTA,DGVET,DGX,DGY,DIE,DIR,DR,DTOUT,DUOUT
+24 ; Do you wish to enroll?
+25 SET DGBACK=0
SET DGSTA=""
SET DGIEN=$$FINDCUR^DGENA(DFN)
IF DGIEN
SET DGSTA=$$GET1^DIQ(27.11,DGIEN_",",.04)
+26 KILL DGOUT
DO GETS^DIQ(2,DFN_",",".3216*","I","DGOUT")
+27 ;DGFDD=Future Discharge Date
SET DGFDD=0
SET DGX=""
FOR
SET DGX=$ORDER(DGOUT(2.3216,DGX),-1)
if DGX=""
QUIT
SET DGFDD=+$GET(DGOUT(2.3216,DGX,.08))
if DGFDD
QUIT
ENRYN SET DGBACK=0
SET DGENRYN=""
SET DGVET=$$VET^DGENPTA(DFN)
if 'DGVET
SET DGENRYN=0
+1 ; DG*5.3*1045 - Newed DGINELIG,DGENPTA,DGIPTAPPLD variables
+2 ; DG*5.3*1027 - Newed E&E Webservice variables
NEW STATUS,DGPREXST,DGPTAPPLD,DGCURR,DGKEY,DGREQNAME,DGENSTAT,DGWSHTOEN,DGRESP,DGDEATH,DGDEAD,DGSHWPRMPT,DGNOENRLL,DGINELIG,DGENPTA,DGIPTAPPLD
+3 ;DG*5.3*1045 Below two lines have logic for Ineligible Date
IF $$GET^DGENPTA(DFN,.DGENPTA)
SET DGINELIG=$GET(DGENPTA("INELDATE"))
+4 SET DGDEAD=0
SET DGIPTAPPLD=""
+5 SET DGDEATH=$$DEATH^DGENPTA(DFN)
IF DGDEATH'=0
SET DGDEAD=1
+6 SET DGPTAPPLD=""
SET DGPREXST=""
SET DGPREXST=$$PREEXIST(DFN)
SET STATUS=""
SET STATUS=$$STATUS^DGENA($GET(DFN))
IF STATUS=25
SET DGENRYN=0
SET DGPREXST=0
+7 SET DGCURR=""
SET DGCURR=$$FINDCUR^DGENA(DFN)
IF DGCURR
SET DGPTAPPLD=$$GET1^DIQ(27.11,DGCURR_",",.14,"I")
+8 IF DGPTAPPLD=1
SET DGENRYN=1
+9 ;DG*5.3*1045 Below two lines have logic for Ineligible Date
IF $GET(DGINELIG)'=""
IF $GET(DGPTAPPLD)=""
SET DGIPTAPPLD=$$GET1^DIQ(2,DFN,27.04,"I")
+10 IF $GET(DGIPTAPPLD)=1
SET DGENRYN=1
+11 ; DG*5.3*1027 Display DO YOU WISH TO ENROLL Prompt if Veteran AND
+12 ; PT APPLIED FOR ENROLLMENT in the Patient Enrollment file is NO
+13 ; There is NO Patient Enrollment record and The patient is unknown to ES
+14 ; Supported DBIA #2701: The supported DBIA is used to access MPI
+15 ; APIs to retrieve ICN, determine if ICN
+16 ; is local and if site is LST.
+17 ; Supported ICRs
+18 ; #3356 - XQY0 ; Kernel Variable
+19 KILL ^TMP($JOB,"DGOLDVET")
+20 ; The ^TMP global is cleaned up in DG REGISTER PATIENT option EXIT ACTION
+21 SET ^TMP($JOB,"DGOLDVET",DFN)=DGVET
+22 SET DGKEY=$$GETICN^MPIF001(DFN)
+23 SET DGREQNAME="VistAData"
+24 SET DGRESP=0
SET DGSHWPRMPT=0
SET DGNOENRLL=0
+25 IF $PIECE(DGKEY,"^",1)'=-1
SET DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
+26 IF '$$FINDCUR^DGENA(DFN)
IF +DGRESP=0
SET DGNOENRLL=1
+27 ; DG*5.3*1027 Modified DGPTAPPLD=0 per RSD
IF ((DGNOENRLL=1)!($GET(DGPTAPPLD)=0))
SET DGSHWPRMPT=1
+28 IF 'DGFDD
IF 'DGDEAD
IF DGVET
IF DGSHWPRMPT
FOR
Begin DoDot:1
+29 KILL DIR,DTOUT
IF ($GET(DGPTAPPLD)=0)
SET DIR("B")="NO"
+30 SET DIR(0)="Y"
SET DIR("A")="DO YOU WISH TO ENROLL"
+31 SET DIR("?")="Select Y or YES if the patient wants to apply for enrollment for VHA Healthcare benefits. Select N or NO if the patient only wants to register without applying for enrollment."
+32 SET DIR("??")="^D HELPENR^DGREG"
+33 DO ^DIR
+34 IF ($GET(DGPTAPPLD)="")&((X["Y")!(X["y"))
Begin DoDot:2
+35 SET DGENRYN=1
+36 NEW DGFDA,DGIENS,DGRSLT
+37 SET DGRSLT=DGENRYN
SET DGIENS=DFN_","
SET DGFDA(2,DGIENS,27.04)=DGRSLT
+38 DO FILE^DIE("","DGFDA")
End DoDot:2
QUIT
+39 IF ($GET(DGPTAPPLD)="")&(X["N")!(X["n")
SET DGENRYN=0
Begin DoDot:2
+40 SET DGENRYN=0
+41 NEW DGFDA,DGIENS,DGRSLT
+42 SET DGRSLT=DGENRYN
SET DGIENS=DFN_","
SET DGFDA(2,DGIENS,27.04)=DGRSLT
+43 ;DG*5.3*1027
DO FILE^DIE("","DGFDA")
+44 ; DG*5.3*1027 Remove appointmnet request data when DGENRYN is changed from Y to N (DGPTAPPLD)=1
IF $PIECE($GET(XQY0),"^",1)="DG REGISTER PATIENT"
IF $GET(DGENRYN)=0
IF $$GET1^DIQ(2,DFN,1010.1512,"I")=1
DO APPTCHG^DGRPC
End DoDot:2
QUIT
+45 IF ($GET(DGPTAPPLD)=0)&(X["Y")!(X["y")
WRITE !!?5,"This is an existing patient. To complete the enrollment"
WRITE !?5,"application process, please use the Enrollment System."
+46 IF ($GET(DGPTAPPLD)=0)&(X["Y")!(X["y")
WRITE !!!?5,"Press <Enter> to Continue or '^' to exit:"
READ X:DTIME
+47 if $DATA(DTOUT)!(X=U)
SET DGBACK=1
End DoDot:1
if DGENRYN'=""!(DGBACK)
QUIT
+48 if DGBACK
GOTO A
+49 if DGFDD
SET DGENRYN=1
+50 SET DGENRRSN=""
SET DGNOW=$$NOW^XLFDT()
+51 ;I (DGENRYN=0)&('DGPREXST) D G:DGENRRSN="^" ENRYN ; Check this condition for prexist from DG 993
+52 IF (DGENRYN=0)
Begin DoDot:1
+53 ;REGISTRATION ONLY REASON
+54 SET DGY=""
SET DGX=$$FINDCUR^DGENA(DFN)
IF DGX?1.N
SET DGY=$$GET1^DIQ(27.11,DGX_",",.15)
+55 ; DG*5.3*1027 Unknown to ES condition added
IF (DGY="")
IF (STATUS="")
IF +DGRESP=0
Begin DoDot:2
+56 ;W !,"SELF-REPORTED REGISTRATION ONLY REASON" ;DG*5.3*1027 - not needed - replaced with code below
+57 ;DG*5.3*1027 place a line in between prompts
WRITE !
+58 FOR
Begin DoDot:3
+59 ; DG*5.3*1027 - Modification of the data entry to field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
+60 KILL DIR
+61 SET DIR(0)="27.11,.15,AO"
+62 SET DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
+63 DO ^DIR
+64 IF $DATA(DTOUT)!$DATA(DUOUT)
SET DGENRRSN="^"
QUIT
+65 SET DGENRRSN=+Y
+66 IF 'DGENRRSN
WRITE !,"This is a required field.",!
QUIT
+67 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration
SET DGENRODT=DGNOW
SET DGENSRCE=1
End DoDot:3
if (DGENRRSN="^")!(DGENRRSN)
QUIT
End DoDot:2
End DoDot:1
if DGENRRSN="^"
GOTO ENRYN
+68 NEW DGBACK,DGENRDTT,ANS,DGAPLDT,DGENRIEN
+69 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+70 SET DGBACK=0
SET DGAPLDT=$$GET1^DIQ(27.11,DGENRIEN_",",.01,"I")
+71 IF (DGENRYN=1)
SET DGEXIT=0
Begin DoDot:1
+72 ;ENROLLMENT APPLICATION DATE
+73 ; Do not display the Application Prompt if application date exists in 27.11 file
+74 ; and do not display APPOINTMENT REQUEST IN 1010EZ prompt
+75 KILL Y
IF $GET(DGAPLDT)=""
DO PROMPT^DGENU(27.11,.01,"NOW",,1,1)
if $EXTRACT(Y)="^"
SET DGEXIT=1
if DGEXIT
QUIT
Begin DoDot:2
+76 SET DGENRDTT=Y
if Y?1.N.E
SET DGENRDT=Y\1
if Y=""
SET DGENRDT=DGNOW\1
SET DGENRDTT=DGNOW
+77 ; If no value for APPT REQUEST, prompt for it
+78 IF $PIECE($GET(^DPT(DFN,1010.15)),"^",9)=""
DO APPTREQ(DGENRDTT,.DGBACK)
End DoDot:2
+79 SET DGY=""
SET DGX=$$FINDCUR^DGENA(DFN)
if DGX?1.N
SET DGY=$$GET1^DIQ(27.11,DGX_",",.16)
IF DGY=""
Begin DoDot:2
+80 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration
SET DGENRRSN=""
SET DGENRODT=DGNOW
SET DGENSRCE=1
End DoDot:2
End DoDot:1
if DGEXIT
GOTO ENRYN
+81 ;
+82 if DGBACK
GOTO ENRYN
+83 ; END OF DG*5.3*993 mods
+84 SET (DGFC,CURR)=0
+85 if '$GET(DGNEW)
DO WARN
SET DA=DFN
SET DGFC="^1"
SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
+86 SET %ZIS="N"
SET IOP="HOME"
DO ^%ZIS
SET DGELVER=0
DO EN^DGRPD
IF $DATA(DGRPOUT)
DO ENDREG($GET(DFN))
DO HL7A08^VAFCDD01
KILL DFN,DGRPOUT
GOTO A
+87 DO HINQ^DG10
+88 ;I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3;DG*5.3*1111-remove Select Admitting Area
+89 ; send financial query
DO REG^IVMCQ($GET(DFN))
+90 GOTO A1
+91 ;
+92 ;
APPTREQ(DGENRDTT,DGBACK) ; Prompt for DO YOU WANT AN APPT. WITH A VA DOCTOR/PROVIDER AS SOON AS AVAILABLE?
+1 ; If YES, update fields #2,#1010.159 and #2,#1010.1511 (NOTE: This code came from DGEN)
+2 ; Input: DGENRDTT - value for ENROLLMENT APPLICATION DATE field 1010.1511 in PATIENT file
+3 ; Output: DGBACK (Pass by Reference) - If set, the user has exited from the prompt
+4 ;
+5 NEW DGSXS,DGAPPTAN,DA,DR,DIE
+6 SET DGSXS=""
SET DGBACK=0
+7 SET DGSXS=$$PROMPT^DGENU(2,1010.159,1,.DGAPPTAN,"",1)
+8 IF 'DGSXS
SET DGBACK=1
QUIT
+9 SET DA=DFN
+10 SET DIE="^DPT("
+11 SET DR="1010.159///^S X=DGAPPTAN"
+12 DO ^DIE
+13 KILL DA,DR,DIE
+14 ; If patient answered YES to "Do you want an appt" question, set APPOINTMENT REQUEST DATE to DGENRDTT
+15 IF DGAPPTAN
Begin DoDot:1
+16 SET DIE="^DPT("
+17 SET DA=DFN
+18 SET DGENRDTT=$$HLDATE^HLFNC(DGENRDTT,"DT")
+19 SET DR="1010.1511///^S X=DGENRDTT"
+20 DO ^DIE
End DoDot:1
+21 ; If patient answered NO to "Do you want an appt" question set APPOINTMENT REQUEST DATE to TODAY
+22 IF DGAPPTAN=0
Begin DoDot:1
+23 SET DIE="^DPT("
+24 SET DA=DFN
+25 SET DR="1010.1511///^S X=DT"
+26 DO ^DIE
End DoDot:1
+27 QUIT
+28 ;
PREEXIST(DFN) ;DG*5.3*993 - Did this patient exist before the installation of DG*5.3*993
+1 NEW DGX,DGINST,DGINSTAT,DGINSTID,DGICN,DGEXIST,DGARR,DGREC,DGESKNOWN,I
+2 SET (DGEXIST,DGICN)=""
+3 SET DGICN=+($$GETICN^MPIF001(DFN))
+4 IF DGICN=-1
QUIT 0
+5 ; check Treating Facility returns 1^text if not found
KILL DGARR
IF DGICN'=-1
SET DGEXIST=$$QUERYTF^VAFCTFU1(DGICN,"DGARR","")
+6 IF $PIECE(DGEXIST,"^",1)=1
QUIT 0
+7 SET DGX=0
SET DGESKNOWN=0
SET I=0
SET DGREC=""
SET DGINSTID=""
FOR I=1:1
if '$DATA(DGARR(I))
QUIT
SET DGREC=DGARR(I)
Begin DoDot:1
+8 SET DGINSTAT=""
SET DGINST=$PIECE(DGREC,"^",1)
+9 SET DGINSTID=$PIECE($GET(^DIC(4,DGINST,9999,1,0)),"^",2)
IF DGINSTID="200ESR"
SET DGINSTAT=$$GET1^DIQ(4,DGINST_",",99)
+10 IF (DGINSTID="200ESR")&(DGINSTAT="200ESR")
SET DGESKNOWN=1
End DoDot:1
if DGESKNOWN=1
QUIT
+11 ;if exist to ES and applied="" it preexist
IF (DGESKNOWN=1)
SET DGX=1
+12 ;not known to ES and not in treating facility (new record)
IF (DGESKNOWN=0)&(DGEXIST'=0)
SET DGX=0
+13 ;new record
IF (DGESKNOWN=0)&(DGEXIST="")
SET DGX=0
+14 QUIT DGX
+15 ;
HELPENR ;DG*5.3*993 - Help for ?? on the DO YOU WISH TO ENROLL? question
+1 WRITE !,"Select Y or YES if the patient wants to apply for enrollment for VHA"
+2 WRITE !,"Healthcare benefits. Select N or NO if the patient only wants to"
+3 WRITE !,"register without applying for enrollment."
+4 QUIT
+5 ;
REASON(Y,XQY0) ; DG*5.3*1027 - Screen logic/Input Transform for field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
+1 ; Input: Y - Entry to be checked
+2 ; XQYO - String containing the option that is being run (may be null when accessing the field from Fileman)
+3 ; Returns: TRUE if the entry Y is valid
+4 ;
+5 ; Supported ICRs:
+6 ; Reference to variable XQY0 supported by ICR #3356 ; Kernel Variable
+7 ; Reference to $$GET^XPAR supported by ICR #2263
+8 ; Reference to $$GET1^DIQ() supported by ICR #2056
+9 ;
+10 ; Check the entry in the 408.43 (PATIENT REGISTRATION ONLY REASON) dictionary
+11 IF '$DATA(^DG(408.43,Y,0))
QUIT 0
+12 ; Entries with AVAILABILITY field = 3 are not valid
+13 IF $PIECE(^DG(408.43,Y,0),U,2)=3
QUIT 0
+14 ; DG*5.3*1067 - For Reg Only Reasons added in patch 1067, screen them out until the date/time in XPAR parameter DG PATCH DG*5.3*1067 ACTIVE is reached
+15 NEW DGREASON,DGACTTS
+16 SET DGREASON=$$GET1^DIQ(408.43,Y_",",.01)
+17 IF DGREASON="CLINICAL EVALUATION"!(DGREASON="4TH MISSION")!(DGREASON="HUD-VASH")!(DGREASON="IMMUNIZATIONS")
Begin DoDot:1
+18 ; Get the timestamp stored in the parameter
+19 SET DGACTTS=$$GET^XPAR("PKG","DG PATCH DG*5.3*1067 ACTIVE",1)
End DoDot:1
IF $$NOW^XLFDT()<DGACTTS
QUIT 0
+20 ; Handle the condition where not within a Vista option or in Programmer mode, default to 0
+21 IF $GET(XQY0)=""!($PIECE($GET(XQY0),U,1)="XUPROGMODE")
NEW DGRET
SET DGRET=0
Begin DoDot:1
+22 ; If direct call to DG COLLATERAL, Only entries with AVAILABILITY field = 2 (COLLATERAL) are valid (variable DR set in ^DGCOL)
+23 IF $GET(DR)="[DGCOLLATERAL]"
IF $PIECE(^DG(408.43,Y,0),U,2)=2
SET DGRET=1
End DoDot:1
QUIT DGRET
+24 ; XQY0 is defined and is not Programmer mode:
+25 ; DG*5.3*1067; If non-Veteran, do not allow CLINICAL EVALUATION
+26 NEW DGVET
+27 SET DGVET=$$VET1^DGENPTA($GET(DFN))
+28 IF 'DGVET
IF DGREASON="CLINICAL EVALUATION"
QUIT 0
+29 ; If not in DG COLLATERAL PATIENT option, all other entries are valid
+30 IF $PIECE(XQY0,U,1)'="DG COLLATERAL PATIENT"
QUIT 1
+31 ; Otherwise, in DG COLLATERAL PATIENT option, only entries with AVAILABILITY field = 2 (COLLATERAL) are valid
+32 IF $PIECE(^DG(408.43,Y,0),U,2)=2
QUIT 1
+33 QUIT 0
+34 ;
PAUSE ;
+1 NEW DIR
+2 SET DIR(0)="E"
DO ^DIR
+3 QUIT
+4 ;
RT ;I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3 ;DG*5.3*1111-remove Select Admitting Area from Register a Patient
+1 QUIT
+2 ;
+3 ; DG*5.3*1040 - If variable DGADDRE=-1, branch to Q due to timeout; if DGRPOUT=1, branch to Q as well
A1 WRITE !,"Do you want to ",$SELECT(DGNEW:"enter",1:"edit")," Patient Data"
SET %=1
DO YN^DICN
Begin DoDot:1
+1 IF +$GET(DGNEW)
QUIT
+2 ; DG*5.3*1040 - Store the return value in DGADDRE
SET DGADDRE=$$ADD^DGADDUTL($GET(DFN))
End DoDot:1
if $GET(DGADDRE)=-1
GOTO Q
if '%
GOTO H
if %'=1
GOTO CK
SET DGRPV=0
DO EN1^DGRP
if +$GET(DGRPOUT)
GOTO Q
if '$DATA(DA)
GOTO Q
+3 GOTO CH
+4 ;DG*5.3*1111 - Remove Is the patient currently being followed in a clinic for the same condition from Register a Patient process
PR ;W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1
GOTO ABIL
+1 ;I '% W !?4,$C(7),"Enter 'Y' if the patient is being followed in clinic for condition for which",!?6,"registered, 'N' if not." G PR
+2 ;S CURR=% G SEEN
+3 ; Killing ^TMP($J,"DGOLDVET",DFN) below ; DG*5.3*1027 cleaning the temp global
CK SET DGEDCN=1
DO ^DGRPC
CH SET X=$SELECT('$DATA(^DPT(DFN,.36)):1,$PIECE(^(.36),"^",1)']"":1,1:0)
SET X1=$SELECT('$DATA(^DPT(DFN,.32)):1,$PIECE(^(.32),"^",3)']"":1,1:0)
IF 'X
IF 'X1
GOTO CH1
CH1 KILL ^TMP($JOB,"DGOLDVET",DFN)
SET DA=DFN
if '$DATA(^DPT("ADA",1,DA))
GOTO PR
WRITE !!,"There is still an open disposition--register aborted.",$CHAR(7),$CHAR(7)
GOTO Q
+1 ;DG*5.3*1111 - remove Is the patient to be examined in the medical center today from Register a Patient process
SEEN ;W !!,"Is the patient to be examined in the medical center today" S %=1 D YN^DICN S SEEN=% G:%<0 Q I %'>0 W !!,"Enter 'Y' if the patient is to be examined today, 'N' if not.",$C(7) G SEEN
ABIL DO ^DGREGG
ENR ; next line appears to be dead code. left commented just to test. mli 4/28/94
+1 ;S DE=0 F I=0:0 S I=$O(^DPT(DA,"DE",I)) Q:'I I $P(^(I,0),"^",3)'?7N Q D PR:'DE S L=+$P($S($D(^SC(L,0)):^(0),1:""),"^",1)
REG SET (DIE,DIC)="^DPT("_DFN_",""DIS"","
SET %DT="PTEX"
SET %DT("A")="Registration login date/time: NOW// "
+1 WRITE !,%DT("A")
READ ANS:DTIME
if '$TEST
SET ANS="^"
if ANS=""
SET ANS="N"
SET X=ANS
if ANS="^"
GOTO Q
SET DA(1)=DFN
DO CHK^DIE(2.101,.01,"E",X,.RESULT)
if RESULT="^"!('$DATA(RESULT))
GOTO REG
if '(RESULT#1)
GOTO PR3
SET Y=RESULT
+2 IF (RESULT'="^")
WRITE " ("_RESULT(0)_")"
+3 SET DINUM=9999999-RESULT
+4 SET (DFN1,Y1)=DINUM
SET APD=Y
IF $DATA(^DPT(DFN,"DIS",Y1))
WRITE !!,"You must enter a date that does not exist.",$CHAR(7),$CHAR(7)
GOTO REG
+5 ;patch 886 changed to incremental lock and dilocktm
+6 if $DATA(^DPT("ADA",1,DA))
GOTO CH1
LOCK +@(DIE_DINUM_")"):$GET(DILOCKTM,3)
if '$TEST
GOTO MSG
if '($DATA(^DPT(DA(1),"DIS",0))#2)
SET ^(0)="^2.101D^^"
SET DIC(0)="L"
SET X=+Y
DO ^DIC
+7 ;
+8 ;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT
+9 SET VAFCDDT=X
+10 ; DG*5.3*993 Decoupling project code for register only
+11 NEW DGSTUS,DGCHK
+12 SET DGCHK=0
+13 ; If DGSTUS=25 patient is Register Only ;27.11 TEST
SET DGSTUS=$$STATUS^DGENA($GET(DFN))
IF DGSTUS=25
SET DGCHK=1
SET DGENRYN=0
+14 ;DG*5.3*993 If DGENRYN=1 patient said YES to enroll
SET DGENRYN=$GET(DGENRYN)
IF DGENRYN=0
SET DGCHK=1
+15 ;DG*5.3*1111-Comments in COMMENTS^DGREG0
+16 NEW DA,SP
+17 SET DA=DFN1
SET DIE("NO^")=""
+18 SET DA(1)=DFN
SET DP=2.101
+19 SET DR="3//"_$SELECT($PIECE(^DG(43,1,"GL"),"^",2):"",1:"/")_$SELECT($DATA(^DG(40.8,+$PIECE(^DG(43,1,"GL"),"^",3),0)):$PIECE(^(0),"^",1),1:"")_";4////"_DUZ
+20 ;patch 886 changed lock to use dilocktm
+21 DO EL
KILL DIC("A")
NEW DGNDLOCK
SET DGNDLOCK=DIE_DFN1_")"
LOCK +@DGNDLOCK:$GET(DILOCKTM,3)
if '$TEST
GOTO MSG
DO ^DIE
LOCK -@DGNDLOCK
+22 IF $DATA(DTOUT)
Begin DoDot:1
+23 KILL DTOUT
+24 NEW DA,DIK
+25 SET DA(1)=DFN
SET DA=DFN1
SET DIK="^DPT("_DFN_",""DIS"","
+26 DO ^DIK
+27 WRITE !!?5,"User Time-out. Required registration data could be missing."
+28 WRITE !,?5,"This registration has been deleted."
End DoDot:1
GOTO Q
+29 ; check whether facility applying to (division) is inactive
+30 IF '$$DIVCHK^DGREGFAC(DFN,DFN1)
GOTO CONT
ASKDIV WRITE !!?5,"The facility chosen either has no pointer to an Institution"
+1 WRITE !?5,"file record or the Institution file record is inactive."
+2 WRITE !?5,"Please choose another division."
+3 SET DA=DFN1
SET DIE("NO^")=""
SET DA(1)=DFN
SET DP=2.101
SET DR="3"
DO ^DIE
+4 IF $$DIVCHK^DGREGFAC(DFN,DFN1)
GOTO ASKDIV
CONT ; continue
+1 SET DGXXXD=1
DO EL^DGREGE
IF $PIECE(^DPT(DFN,"DIS",DFN1,0),"^",3)=4
SET DA=DFN
SET DIE="^DPT("
SET DR=".368;.369"
DO ^DIE
SET DIE="^DPT("_DFN_",""DIS"","
SET DA(1)=DFN
SET DA=DFN1
+2 ;S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^") ;DG*5.3*1111 - The DGREG input template prompts grouping is removed
+3 IF $DATA(^DPT(DFN,"DIS",DFN1,2))
IF $PIECE(^(2),"^",1)="Y"
SET DIE="^DPT("
SET DR="[DG EMPLOYER]"
SET DA=DFN
DO ^DIE
+4 GOTO ^DGREG0
PR2 WRITE !!,"You can only enter new registrations through this option.",$CHAR(7),$CHAR(7)
GOTO REG
PR3 WRITE !!,"Time is required to register the patient.",!!,$CHAR(7),$CHAR(7)
GOTO REG
H WRITE !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue."
GOTO A1
+1 ; DG*5.3*1040 - Cleanup variable DGTMOT
Q KILL DG,DQ,DGTMOT
GOTO Q1^DGREG0
Q1 KILL DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW
QUIT
EL SET DR=DR_";13//"
IF $DATA(^DPT(DFN,.36))
IF $DATA(^DIC(8,+^(.36),0))
SET DR=DR_$PIECE(^(0),"^",1)
QUIT
+1 SET DR=DR_"HUMANITARIAN EMERGENCY"
QUIT
FEE SET DGRPFEE=1
DO DGREG
KILL DGRPFEE
GOTO Q1
+1 ;
WARN IF $SELECT('$DATA(^DPT(DFN,.1)):0,$PIECE(^(.1),"^",1)']"":0,1:1)
WRITE !,$CHAR(7),"***PATIENT IS CURRENTLY AN INPATIENT***",!
HANG 2
+1 IF $SELECT('$DATA(^DPT(DFN,.107)):0,$PIECE(^(.107),"^",1)']"":0,1:1)
WRITE !,$CHAR(7),"***PATIENT IS CURRENTLY A LODGER***",!
HANG 2
+2 QUIT
MSG WRITE !,"Another user is editing, try later ..."
GOTO Q
+1 ;
BEGINREG(DFN) ;
+1 NEW DGQRY
+2 ;Description: This is called at the beginning of the registration process.
+3 ;Concurrent processes can check the lock to determine if the patient is
+4 ;currently being registered.
+5 ;
+6 if '$GET(DFN)
QUIT 0
+7 ; **915, check to see if a query was done within the last 5 minutes so we don't send again
+8 SET DGQRY=$$GET^DGENQRY($$FINDLAST^DGENQRY($GET(DFN)),.DGQRY)
+9 IF $$FMDIFF^XLFDT($$NOW^XLFDT,$GET(DGQRY("SENT")),2)>300
IF $$QRY^DGENQRY(DFN)
WRITE !!,"Enrollment/Eligibility Query sent ...",!!
+10 ;patch 886 changed lock to use dilocktm
+11 LOCK +^TMP(DFN,"REGISTRATION IN PROGRESS"):$GET(DILOCKTM,3)
+12 ;try to lock the patient record
IF $$LOCK^DGENPTA1(DFN)
+13 QUIT
+14 ;
ENDREG(DFN) ;
+1 ;Description: releases the lock obtained by calling BEGINREG.
+2 ;
+3 if '$GET(DFN)
QUIT
+4 LOCK -^TMP(DFN,"REGISTRATION IN PROGRESS")
+5 DO UNLOCK^DGENPTA1(DFN)
+6 QUIT
+7 ;
IFREG(DFN) ;
+1 ;Description: tests whether the lock set by BEGINREG is set
+2 ;
+3 ;Input: DFN
+4 ;Output:
+5 ; Function Value = 1 if lock is set, 0 otherwise
+6 ;
+7 NEW RETURN
+8 if '$GET(DFN)
QUIT 0
+9 ;patch 886 changed lock to use dilocktm
+10 LOCK +^TMP(DFN,"REGISTRATION IN PROGRESS"):$GET(DILOCKTM,3)
+11 SET RETURN='$TEST
+12 LOCK -^TMP(DFN,"REGISTRATION IN PROGRESS")
+13 QUIT RETURN
+14 QUIT
CIRN ;MPI QUERY
+1 ;check to see if CIRN PD/MPI is installed
+2 NEW X
SET X="MPIFAPI"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+3 KILL MPIFRTN
+4 DO MPIQ^MPIFAPI(DFN)
+5 KILL MPIFRTN
+6 QUIT
ROMQRY ;**926 TRIGGER IB INSURANCE QUERY
+1 NEW ZTSAVE,A,ZTRTN,ZTDESC,ZTIO,ZTDTH,DGMSG
+2 ;Invoke IB Insurance Query (Query was introduced with IB*2.0*214)
+3 ;DG*1102/TAZ - Check Insurance Import Enabled flag
+4 ; Reference to Field 54.01 in File 350.9 supported by ICR #7429
+5 IF '$$GET1^DIQ(350.9,"1,",54.01,"I")
Begin DoDot:1
+6 SET DGMSG(1)="Insurance data retrieval is not currently enabled."
+7 SET DGMSG(2)=" "
DO EN^DDIOL(.DGMSG)
READ A:5
End DoDot:1
QUIT
+8 SET ZTSAVE("IBTYPE")=1
SET ZTSAVE("DFN")=DFN
SET ZTSAVE("IBDUZ")=$GET(DUZ)
+9 ; Reference to BACKGND^IBCNRDV supported by ICR #4288
+10 SET ZTRTN="BACKGND^IBCNRDV"
SET ZTDTH=$HOROLOG
SET ZTDESC="IBCN INSURANCE QUERY TASK"
SET ZTIO=""
+11 DO ^%ZTLOAD
+12 ;display busy message to interactive users
+13 SET DGMSG(1)="Insurance data retrieval has been initiated."
+14 SET DGMSG(2)=" "
DO EN^DDIOL(.DGMSG)
+15 ;**915 all "register once" functionality eliminated additional
+16 ; checks that use to be below this line.
+17 ;**915 all register once functionality no longer executed and removed
QUIT
