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-REGISTER PATIENT ; 8/24/05 1:40pm
  1.  ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,1015**;Aug 13, 1993;Build 21
  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.  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=$P(Y,"^",3) 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.  ;
  1.  D ROMQRY
  1.  ;
  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
  1.  D REG^IVMCQ($G(DFN))  ; send financial query  
  1.  G A1
  1.  ;
  1. RT I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3
  1.  Q
  1.  ;
  1. A1 W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" S %=1 D YN^DICN D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G Q:'$D(DA)
  1.  .I +$G(DGNEW) Q
  1.  .I $$ADD^DGADDUTL($G(DFN)) ;
  1.  G CH
  1. PR 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.  ;
  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 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. 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.  G:$D(^DPT("ADA",1,DA)) CH1 L @(DIE_DINUM_")"):2 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.  ;
  1.  S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;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.  D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 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^")
  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. Q K DG,DQ 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.  ;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.  I $$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!!
  1.  L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
  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.  L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
  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 ;
  1.  I +$G(DGNEW) D
  1.  . ; query LST for Patient Demographic Information if NEW patient and
  1.  . ; file into patient's record.
  1.  . N A
  1.  . I $$ROMQRY^DGROAPI(DFN) D
  1.  . . ;display busy message to interactive users
  1.  . .S DGMSG(1)="Data retrieval from LST site has been completed successfully"
  1.  . .S DGMSG(2)="Thank you for your patience."
  1.  . .D EN^DDIOL(.DGMSG) R A:5
  1.  . E  D
  1.  . . ;display busy message to interactive users
  1.  . .S DGMSG(1)="Data retrieval from LST site has not been successful."
  1.  . .S DGMSG(2)="Please continue the Registration Process."
  1.  . .D EN^DDIOL(.DGMSG) R A:5
  1.  . ;
  1.  Q