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

DGREG.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; DG*5.3*1075 - Fix line 1 for SAC compliance
  1. ; Reference to (#350.9,54.01) supported by ICR #7429
  1. ; Reference to BACKGND^IBCNRDV supported by ICR #4288
  1. ;
  1. START ;
  1. EN D LO^DGUTL S DGCLPR=""
  1. N DGDIV
  1. S DGDIV=$$PRIM^VASITE
  1. S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1)
  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
  1. K %ZIS("B")
  1. 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
  1. A D ENDREG($G(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
  1. N DGADDRE,DGTMOT S DGTMOT=0,DGADDRE=""
  1. N DGNEWP ;**1024 USING DGNEWP INSTEAD OF JUST DGNEWP TO AVOID Y BEING RESET ON US
  1. 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
  1. ;
  1. ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
  1. S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1)
  1. I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A
  1. ;
  1. D CIRN
  1. ;
  1. I +$G(DGNEW) D
  1. . ; query CMOR for Patient Record Flag Assignments if NEW patient and
  1. . ; display results.
  1. . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
  1. . I $$EN^DGPFMPI(DFN)
  1. ;
  1. D ROMQRY
  1. ;
  1. ; DG*5.3*993 The DO YOU WISH TO ENROLL, ENROLLMENT DATE, and DO YOU WANT AN APPT questions
  1. ; were moved here from the end of patient registration. Also, if the patient does not wish to enroll
  1. ; a REGISTRATION REASON question will be asked
  1. N DGBACK,DGENRDT,DGENRIEN,DGENRRSN,DGENRYN,DGERR,DGEXIT,DGFDA,DGFDD,DGIEN,DGNOW,DGOUT,DGSTA,DGVET,DGX,DGY,DIE,DIR,DR,DTOUT,DUOUT
  1. ; Do you wish to enroll?
  1. S DGBACK=0,DGSTA="",DGIEN=$$FINDCUR^DGENA(DFN) I DGIEN S DGSTA=$$GET1^DIQ(27.11,DGIEN_",",.04)
  1. K DGOUT D GETS^DIQ(2,DFN_",",".3216*","I","DGOUT")
  1. 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
  1. ENRYN S DGBACK=0,DGENRYN="",DGVET=$$VET^DGENPTA(DFN) S:'DGVET DGENRYN=0
  1. ; DG*5.3*1045 - Newed DGINELIG,DGENPTA,DGIPTAPPLD variables
  1. 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
  1. I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE")) ;DG*5.3*1045 Below two lines have logic for Ineligible Date
  1. S DGDEAD=0,DGIPTAPPLD=""
  1. S DGDEATH=$$DEATH^DGENPTA(DFN) I DGDEATH'=0 S DGDEAD=1
  1. S DGPTAPPLD="",DGPREXST="",DGPREXST=$$PREEXIST(DFN),STATUS="",STATUS=$$STATUS^DGENA($G(DFN)) I STATUS=25 S DGENRYN=0,DGPREXST=0
  1. S DGCURR="",DGCURR=$$FINDCUR^DGENA(DFN) I DGCURR S DGPTAPPLD=$$GET1^DIQ(27.11,DGCURR_",",.14,"I")
  1. I DGPTAPPLD=1 S DGENRYN=1
  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
  1. I $G(DGIPTAPPLD)=1 S DGENRYN=1
  1. ; DG*5.3*1027 Display DO YOU WISH TO ENROLL Prompt if Veteran AND
  1. ; PT APPLIED FOR ENROLLMENT in the Patient Enrollment file is NO
  1. ; There is NO Patient Enrollment record and The patient is unknown to ES
  1. ; Supported DBIA #2701: The supported DBIA is used to access MPI
  1. ; APIs to retrieve ICN, determine if ICN
  1. ; is local and if site is LST.
  1. ; Supported ICRs
  1. ; #3356 - XQY0 ; Kernel Variable
  1. K ^TMP($J,"DGOLDVET")
  1. ; The ^TMP global is cleaned up in DG REGISTER PATIENT option EXIT ACTION
  1. S ^TMP($J,"DGOLDVET",DFN)=DGVET
  1. S DGKEY=$$GETICN^MPIF001(DFN)
  1. S DGREQNAME="VistAData"
  1. S DGRESP=0,DGSHWPRMPT=0,DGNOENRLL=0
  1. I $P(DGKEY,"^",1)'=-1 S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
  1. I '$$FINDCUR^DGENA(DFN),+DGRESP=0 S DGNOENRLL=1
  1. I ((DGNOENRLL=1)!($G(DGPTAPPLD)=0)) S DGSHWPRMPT=1 ; DG*5.3*1027 Modified DGPTAPPLD=0 per RSD
  1. I 'DGFDD,'DGDEAD,DGVET,DGSHWPRMPT F D Q:DGENRYN'=""!(DGBACK)
  1. . K DIR,DTOUT I ($G(DGPTAPPLD)=0) S DIR("B")="NO"
  1. . S DIR(0)="Y",DIR("A")="DO YOU WISH TO ENROLL"
  1. . 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."
  1. . S DIR("??")="^D HELPENR^DGREG"
  1. . D ^DIR
  1. . I ($G(DGPTAPPLD)="")&((X["Y")!(X["y")) D Q
  1. . . S DGENRYN=1
  1. . . N DGFDA,DGIENS,DGRSLT
  1. . . S DGRSLT=DGENRYN,DGIENS=DFN_",",DGFDA(2,DGIENS,27.04)=DGRSLT
  1. . . D FILE^DIE("","DGFDA")
  1. . I ($G(DGPTAPPLD)="")&(X["N")!(X["n") S DGENRYN=0 D Q
  1. . . S DGENRYN=0
  1. . . N DGFDA,DGIENS,DGRSLT
  1. . . S DGRSLT=DGENRYN,DGIENS=DFN_",",DGFDA(2,DGIENS,27.04)=DGRSLT
  1. . . D FILE^DIE("","DGFDA") ;DG*5.3*1027
  1. . . 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
  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."
  1. . I ($G(DGPTAPPLD)=0)&(X["Y")!(X["y") W !!!?5,"Press <Enter> to Continue or '^' to exit:" R X:DTIME
  1. . S:$D(DTOUT)!(X=U) DGBACK=1
  1. G:DGBACK A
  1. S:DGFDD DGENRYN=1
  1. S DGENRRSN="",DGNOW=$$NOW^XLFDT()
  1. ;I (DGENRYN=0)&('DGPREXST) D G:DGENRRSN="^" ENRYN ; Check this condition for prexist from DG 993
  1. I (DGENRYN=0) D G:DGENRRSN="^" ENRYN
  1. . ;REGISTRATION ONLY REASON
  1. . S DGY="",DGX=$$FINDCUR^DGENA(DFN) I DGX?1.N S DGY=$$GET1^DIQ(27.11,DGX_",",.15)
  1. . I (DGY=""),(STATUS=""),+DGRESP=0 D ; DG*5.3*1027 Unknown to ES condition added
  1. . . ;W !,"SELF-REPORTED REGISTRATION ONLY REASON" ;DG*5.3*1027 - not needed - replaced with code below
  1. . . W ! ;DG*5.3*1027 place a line in between prompts
  1. . . F D Q:(DGENRRSN="^")!(DGENRRSN)
  1. . . . ; DG*5.3*1027 - Modification of the data entry to field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
  1. . . . K DIR
  1. . . . S DIR(0)="27.11,.15,AO"
  1. . . . S DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
  1. . . . D ^DIR
  1. . . . I $D(DTOUT)!$D(DUOUT) S DGENRRSN="^" Q
  1. . . . S DGENRRSN=+Y
  1. . . . I 'DGENRRSN W !,"This is a required field.",! Q
  1. . . . S DGENRODT=DGNOW,DGENSRCE=1 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration
  1. N DGBACK,DGENRDTT,ANS,DGAPLDT,DGENRIEN
  1. S DGENRIEN=$$FINDCUR^DGENA(DFN)
  1. S DGBACK=0,DGAPLDT=$$GET1^DIQ(27.11,DGENRIEN_",",.01,"I")
  1. I (DGENRYN=1) S DGEXIT=0 D G:DGEXIT ENRYN
  1. . ;ENROLLMENT APPLICATION DATE
  1. . ; Do not display the Application Prompt if application date exists in 27.11 file
  1. . ; and do not display APPOINTMENT REQUEST IN 1010EZ prompt
  1. . K Y I $G(DGAPLDT)="" D PROMPT^DGENU(27.11,.01,"NOW",,1,1) S:$E(Y)="^" DGEXIT=1 Q:DGEXIT D
  1. . . S DGENRDTT=Y S:Y?1.N.E DGENRDT=Y\1 S:Y="" DGENRDT=DGNOW\1,DGENRDTT=DGNOW
  1. . . ; If no value for APPT REQUEST, prompt for it
  1. . . I $P($G(^DPT(DFN,1010.15)),"^",9)="" D APPTREQ(DGENRDTT,.DGBACK)
  1. . S DGY="",DGX=$$FINDCUR^DGENA(DFN) S:DGX?1.N DGY=$$GET1^DIQ(27.11,DGX_",",.16) I DGY="" D
  1. . . S DGENRRSN="",DGENRODT=DGNOW,DGENSRCE=1 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration
  1. ;
  1. G:DGBACK ENRYN
  1. ; END OF DG*5.3*993 mods
  1. S (DGFC,CURR)=0
  1. D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
  1. 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
  1. D HINQ^DG10
  1. ;I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3;DG*5.3*1111-remove Select Admitting Area
  1. D REG^IVMCQ($G(DFN)) ; send financial query
  1. G A1
  1. ;
  1. ;
  1. 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)
  1. ; Input: DGENRDTT - value for ENROLLMENT APPLICATION DATE field 1010.1511 in PATIENT file
  1. ; Output: DGBACK (Pass by Reference) - If set, the user has exited from the prompt
  1. ;
  1. N DGSXS,DGAPPTAN,DA,DR,DIE
  1. S DGSXS="",DGBACK=0
  1. S DGSXS=$$PROMPT^DGENU(2,1010.159,1,.DGAPPTAN,"",1)
  1. I 'DGSXS S DGBACK=1 Q
  1. S DA=DFN
  1. S DIE="^DPT("
  1. S DR="1010.159///^S X=DGAPPTAN"
  1. D ^DIE
  1. K DA,DR,DIE
  1. ; If patient answered YES to "Do you want an appt" question, set APPOINTMENT REQUEST DATE to DGENRDTT
  1. I DGAPPTAN D
  1. . S DIE="^DPT("
  1. . S DA=DFN
  1. . S DGENRDTT=$$HLDATE^HLFNC(DGENRDTT,"DT")
  1. . S DR="1010.1511///^S X=DGENRDTT"
  1. . D ^DIE
  1. ; If patient answered NO to "Do you want an appt" question set APPOINTMENT REQUEST DATE to TODAY
  1. I DGAPPTAN=0 D
  1. . S DIE="^DPT("
  1. . S DA=DFN
  1. . S DR="1010.1511///^S X=DT"
  1. . D ^DIE
  1. Q
  1. ;
  1. PREEXIST(DFN) ;DG*5.3*993 - Did this patient exist before the installation of DG*5.3*993
  1. N DGX,DGINST,DGINSTAT,DGINSTID,DGICN,DGEXIST,DGARR,DGREC,DGESKNOWN,I
  1. S (DGEXIST,DGICN)=""
  1. S DGICN=+($$GETICN^MPIF001(DFN))
  1. I DGICN=-1 Q 0
  1. K DGARR I DGICN'=-1 S DGEXIST=$$QUERYTF^VAFCTFU1(DGICN,"DGARR","") ; check Treating Facility returns 1^text if not found
  1. I $P(DGEXIST,"^",1)=1 Q 0
  1. 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
  1. . S DGINSTAT="",DGINST=$P(DGREC,"^",1)
  1. . S DGINSTID=$P($G(^DIC(4,DGINST,9999,1,0)),"^",2) I DGINSTID="200ESR" S DGINSTAT=$$GET1^DIQ(4,DGINST_",",99)
  1. . I (DGINSTID="200ESR")&(DGINSTAT="200ESR") S DGESKNOWN=1
  1. I (DGESKNOWN=1) S DGX=1 ;if exist to ES and applied="" it preexist
  1. I (DGESKNOWN=0)&(DGEXIST'=0) S DGX=0 ;not known to ES and not in treating facility (new record)
  1. I (DGESKNOWN=0)&(DGEXIST="") S DGX=0 ;new record
  1. Q DGX
  1. ;
  1. HELPENR ;DG*5.3*993 - Help for ?? on the DO YOU WISH TO ENROLL? question
  1. W !,"Select Y or YES if the patient wants to apply for enrollment for VHA"
  1. W !,"Healthcare benefits. Select N or NO if the patient only wants to"
  1. W !,"register without applying for enrollment."
  1. Q
  1. ;
  1. 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
  1. ; XQYO - String containing the option that is being run (may be null when accessing the field from Fileman)
  1. ; Returns: TRUE if the entry Y is valid
  1. ;
  1. ; Supported ICRs:
  1. ; Reference to variable XQY0 supported by ICR #3356 ; Kernel Variable
  1. ; Reference to $$GET^XPAR supported by ICR #2263
  1. ; Reference to $$GET1^DIQ() supported by ICR #2056
  1. ;
  1. ; Check the entry in the 408.43 (PATIENT REGISTRATION ONLY REASON) dictionary
  1. I '$D(^DG(408.43,Y,0)) Q 0
  1. ; Entries with AVAILABILITY field = 3 are not valid
  1. I $P(^DG(408.43,Y,0),U,2)=3 Q 0
  1. ; 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
  1. N DGREASON,DGACTTS
  1. S DGREASON=$$GET1^DIQ(408.43,Y_",",.01)
  1. I DGREASON="CLINICAL EVALUATION"!(DGREASON="4TH MISSION")!(DGREASON="HUD-VASH")!(DGREASON="IMMUNIZATIONS") D I $$NOW^XLFDT()<DGACTTS Q 0
  1. . ; Get the timestamp stored in the parameter
  1. . S DGACTTS=$$GET^XPAR("PKG","DG PATCH DG*5.3*1067 ACTIVE",1)
  1. ; Handle the condition where not within a Vista option or in Programmer mode, default to 0
  1. I $G(XQY0)=""!($P($G(XQY0),U,1)="XUPROGMODE") N DGRET S DGRET=0 D Q DGRET
  1. . ; If direct call to DG COLLATERAL, Only entries with AVAILABILITY field = 2 (COLLATERAL) are valid (variable DR set in ^DGCOL)
  1. . I $G(DR)="[DGCOLLATERAL]" I $P(^DG(408.43,Y,0),U,2)=2 S DGRET=1
  1. ; XQY0 is defined and is not Programmer mode:
  1. ; DG*5.3*1067; If non-Veteran, do not allow CLINICAL EVALUATION
  1. N DGVET
  1. S DGVET=$$VET1^DGENPTA($G(DFN))
  1. I 'DGVET,DGREASON="CLINICAL EVALUATION" Q 0
  1. ; If not in DG COLLATERAL PATIENT option, all other entries are valid
  1. I $P(XQY0,U,1)'="DG COLLATERAL PATIENT" Q 1
  1. ; Otherwise, in DG COLLATERAL PATIENT option, only entries with AVAILABILITY field = 2 (COLLATERAL) are valid
  1. I $P(^DG(408.43,Y,0),U,2)=2 Q 1
  1. Q 0
  1. ;
  1. PAUSE ;
  1. N DIR
  1. S DIR(0)="E" D ^DIR
  1. Q
  1. ;
  1. 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. Q
  1. ;
  1. ; DG*5.3*1040 - If variable DGADDRE=-1, branch to Q due to timeout; if DGRPOUT=1, branch to Q as well
  1. 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)
  1. .I +$G(DGNEW) Q
  1. .S DGADDRE=$$ADD^DGADDUTL($G(DFN)) ; DG*5.3*1040 - Store the return value in DGADDRE
  1. G CH
  1. ;DG*5.3*1111 - Remove Is the patient currently being followed in a clinic for the same condition from Register a Patient process
  1. 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
  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
  1. ;S CURR=% G SEEN
  1. ; Killing ^TMP($J,"DGOLDVET",DFN) below ; DG*5.3*1027 cleaning the temp global
  1. CK S DGEDCN=1 D ^DGRPC
  1. 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
  1. 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
  1. ;DG*5.3*1111 - remove Is the patient to be examined in the medical center today from Register a Patient process
  1. 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
  1. ABIL D ^DGREGG
  1. 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)
  1. REG S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// "
  1. 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
  1. I (RESULT'="^") W " ("_RESULT(0)_")"
  1. S DINUM=9999999-RESULT
  1. 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
  1. ;patch 886 changed to incremental lock and dilocktm
  1. 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
  1. ;
  1. ;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT
  1. S VAFCDDT=X
  1. ; DG*5.3*993 Decoupling project code for register only
  1. N DGSTUS,DGCHK
  1. S DGCHK=0
  1. S DGSTUS=$$STATUS^DGENA($G(DFN)) I DGSTUS=25 S DGCHK=1,DGENRYN=0 ; If DGSTUS=25 patient is Register Only ;27.11 TEST
  1. S DGENRYN=$G(DGENRYN) I DGENRYN=0 S DGCHK=1 ;DG*5.3*993 If DGENRYN=1 patient said YES to enroll
  1. ;DG*5.3*1111-Comments in COMMENTS^DGREG0
  1. N DA,SP
  1. S DA=DFN1,DIE("NO^")=""
  1. S DA(1)=DFN,DP=2.101
  1. 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
  1. ;patch 886 changed lock to use dilocktm
  1. D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:$G(DILOCKTM,3) G:'$T MSG D ^DIE L -@DGNDLOCK
  1. I $D(DTOUT) D G Q
  1. .K DTOUT
  1. .N DA,DIK
  1. .S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS"","
  1. .D ^DIK
  1. .W !!?5,"User Time-out. Required registration data could be missing."
  1. .W !,?5,"This registration has been deleted."
  1. ; check whether facility applying to (division) is inactive
  1. I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT
  1. ASKDIV W !!?5,"The facility chosen either has no pointer to an Institution"
  1. W !?5,"file record or the Institution file record is inactive."
  1. W !?5,"Please choose another division."
  1. S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE
  1. I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV
  1. CONT ; continue
  1. 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
  1. ;S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^") ;DG*5.3*1111 - The DGREG input template prompts grouping is removed
  1. I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE
  1. G ^DGREG0
  1. PR2 W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG
  1. PR3 W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG
  1. H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1
  1. ; DG*5.3*1040 - Cleanup variable DGTMOT
  1. Q K DG,DQ,DGTMOT G Q1^DGREG0
  1. Q1 K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q
  1. EL S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q
  1. S DR=DR_"HUMANITARIAN EMERGENCY" Q
  1. FEE S DGRPFEE=1 D DGREG K DGRPFEE G Q1
  1. ;
  1. WARN I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2
  1. I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2
  1. Q
  1. MSG W !,"Another user is editing, try later ..." G Q
  1. ;
  1. BEGINREG(DFN) ;
  1. N DGQRY
  1. ;Description: This is called at the beginning of the registration process.
  1. ;Concurrent processes can check the lock to determine if the patient is
  1. ;currently being registered.
  1. ;
  1. Q:'$G(DFN) 0
  1. ; **915, check to see if a query was done within the last 5 minutes so we don't send again
  1. S DGQRY=$$GET^DGENQRY($$FINDLAST^DGENQRY($G(DFN)),.DGQRY)
  1. I $$FMDIFF^XLFDT($$NOW^XLFDT,$G(DGQRY("SENT")),2)>300,$$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!!
  1. ;patch 886 changed lock to use dilocktm
  1. L +^TMP(DFN,"REGISTRATION IN PROGRESS"):$G(DILOCKTM,3)
  1. I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record
  1. Q
  1. ;
  1. ENDREG(DFN) ;
  1. ;Description: releases the lock obtained by calling BEGINREG.
  1. ;
  1. Q:'$G(DFN)
  1. L -^TMP(DFN,"REGISTRATION IN PROGRESS")
  1. D UNLOCK^DGENPTA1(DFN)
  1. Q
  1. ;
  1. IFREG(DFN) ;
  1. ;Description: tests whether the lock set by BEGINREG is set
  1. ;
  1. ;Input: DFN
  1. ;Output:
  1. ; Function Value = 1 if lock is set, 0 otherwise
  1. ;
  1. N RETURN
  1. Q:'$G(DFN) 0
  1. ;patch 886 changed lock to use dilocktm
  1. L +^TMP(DFN,"REGISTRATION IN PROGRESS"):$G(DILOCKTM,3)
  1. S RETURN='$T
  1. L -^TMP(DFN,"REGISTRATION IN PROGRESS")
  1. Q RETURN
  1. Q
  1. CIRN ;MPI QUERY
  1. ;check to see if CIRN PD/MPI is installed
  1. N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T
  1. K MPIFRTN
  1. D MPIQ^MPIFAPI(DFN)
  1. K MPIFRTN
  1. Q
  1. ROMQRY ;**926 TRIGGER IB INSURANCE QUERY
  1. N ZTSAVE,A,ZTRTN,ZTDESC,ZTIO,ZTDTH,DGMSG
  1. ;Invoke IB Insurance Query (Query was introduced with IB*2.0*214)
  1. ;DG*1102/TAZ - Check Insurance Import Enabled flag
  1. ; Reference to Field 54.01 in File 350.9 supported by ICR #7429
  1. I '$$GET1^DIQ(350.9,"1,",54.01,"I") D Q
  1. . S DGMSG(1)="Insurance data retrieval is not currently enabled."
  1. . S DGMSG(2)=" " D EN^DDIOL(.DGMSG) R A:5
  1. S ZTSAVE("IBTYPE")=1,ZTSAVE("DFN")=DFN,ZTSAVE("IBDUZ")=$G(DUZ)
  1. ; Reference to BACKGND^IBCNRDV supported by ICR #4288
  1. S ZTRTN="BACKGND^IBCNRDV",ZTDTH=$H,ZTDESC="IBCN INSURANCE QUERY TASK",ZTIO=""
  1. D ^%ZTLOAD
  1. ;display busy message to interactive users
  1. S DGMSG(1)="Insurance data retrieval has been initiated."
  1. S DGMSG(2)=" " D EN^DDIOL(.DGMSG)
  1. ;**915 all "register once" functionality eliminated additional
  1. ; checks that use to be below this line.
  1. Q ;**915 all register once functionality no longer executed and removed