Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m
r613 r623 1 DGREG 2 ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 30 3 4 5 6 7 8 9 10 11 START 12 EN 13 14 15 16 17 18 19 A 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 RT 102 103 104 A1 105 106 107 108 PR 109 110 111 112 CK 113 CH 114 CH1 115 SEEN 116 ABIL 117 ENR 118 119 REG 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 ASKDIV 152 153 154 155 156 CONT 157 158 159 160 161 PR2 162 PR3 163 H 164 Q 165 Q1 166 EL 167 168 FEE 169 170 WARN 171 172 173 MSG 174 175 BEGINREG(DFN) 176 177 178 179 180 181 182 183 184 185 186 ENDREG(DFN) 187 188 189 190 191 192 193 194 IFREG(DFN) 195 196 197 198 199 200 201 202 203 204 205 206 207 208 CIRN 209 210 211 212 213 214 215 ROMQRY 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 1 DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ;1/27/07 13:08 2 ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 28 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 START ; 12 EN D LO^DGUTL S DGCLPR="" 13 N DGDIV 14 S DGDIV=$$PRIM^VASITE 15 S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1) 16 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 17 K %ZIS("B") 18 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 19 A D ENDREG($G(DFN)) 20 ; 21 ; ** VOE change 1 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 ** 22 ; 23 ; if not VA agency code, add DIC("DR") to default some identifiers and 24 ; skip others also, improve readability 25 ; 26 ; before change: 27 ; 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 28 ; 29 ; after change: 30 W !! 31 N Y,DGREGY S DGREGY=1 D I DGREGY<0 G Q1 32 . N DIC S DIC=2 ; Patient file 33 . S DIC(0)="ALEQM" ; ask, laygo, echo, question, and multi-index 34 . N DLAYGO S DLAYGO=2 ; override file access by user: allow laygo 35 . I $G(DUZ("AG"))'="V" D ;adjust identifiers asked for VOE 36 . . S DIC("DR")=".02;.03;994;.301///N;391///VISTA OFFICE EHR;1901///N;.09" 37 . ; 38 . D ^DIC ; Select Patient 39 . ; 40 . I Y<0 S DGREGY=-1 Q 41 . K DIC("DR") 42 . S (DFN,DA)=+Y 43 . S DGNEW=$P(Y,"^",3) ; new patient? 44 . N Y D PAUSE^DG10 ; prompt user before continuing 45 . D BEGINREG(DFN) ; lock patient record 46 ; 47 ; ** end of VOE change 1 ** 48 ; 49 ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04 50 S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1) 51 I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A 52 ; 53 D CIRN 54 ; 55 ; ** VOE change 2 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 ** 56 ; 57 I $G(DGNEW) D NEW^DGRP ; execute new patient DR string 58 ; 59 ; send CMOR query and display results only if VA agency code 60 ; 61 ; before change: 62 ; I +$G(DGNEW) D 63 ; 64 ; after change: 65 I $G(DGNEW),$G(DUZ("AG"))="V" D 66 . ; 67 . ; end of change 68 . ; 69 . ; query CMOR for Patient Record Flag Assignments if NEW patient and 70 . ; display results. 71 . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) 72 ; 73 ; before change: 74 ; D ROMQRY 75 ; 76 ; after change: 77 I $G(DUZ("AG"))="V" D ROMQRY 78 ; 79 ; ** end of VOE change 2 ** 80 ; 81 S (DGFC,CURR)=0 82 D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0) 83 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 84 D HINQ^DG10 85 I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3 86 ; 87 ; ** VOE change 3 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 ** 88 ; 89 ; send financial query only for VA agency code 90 ; 91 ; before change: 92 ; D REG^IVMCQ($G(DFN)) ; send financial query 93 ; 94 ; after change: 95 I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN)) ; send financial query 96 ; 97 ; ** end of VOE change 3 ** 98 ; 99 G A1 100 ; 101 RT I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3 102 Q 103 ; 104 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) 105 .I +$G(DGNEW) Q 106 .I $$ADD^DGADDUTL($G(DFN)) ; 107 G CH 108 PR W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1 109 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 110 S CURR=% G SEEN 111 ; 112 CK S DGEDCN=1 D ^DGRPC 113 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 114 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 115 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 116 ABIL D ^DGREGG 117 ENR ; next line appears to be dead code. left commented just to test. mli 4/28/94 118 ;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) 119 REG S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// " 120 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 121 I (RESULT'="^") W " ("_RESULT(0)_")" 122 S DINUM=9999999-RESULT 123 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 124 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 125 ; 126 ;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT 127 S VAFCDDT=X 128 ; 129 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 130 ; 131 ; ** VOE change 4 of 4: DAOU/JLG 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 ** 132 ; 133 ; for VOE or IHS agency codes, add the following: 134 ; force TYPE OF CARE with ALL OTHER 135 ; 136 I $G(DUZ("AG"))="E"!($G(DUZ("AG"))="I") D 137 . S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1///5;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 138 ; 139 ; ** end of VOE change 4 ** 140 ; 141 D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 G:'$T MSG D ^DIE L -@DGNDLOCK 142 I $D(DTOUT) D G Q 143 .K DTOUT 144 .N DA,DIK 145 .S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS""," 146 .D ^DIK 147 .W !!?5,"User Time-out. Required registration data could be missing." 148 .W !,?5,"This registration has been deleted." 149 ; check whether facility applying to (division) is inactive 150 I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT 151 ASKDIV W !!?5,"The facility chosen either has no pointer to an Institution" 152 W !?5,"file record or the Institution file record is inactive." 153 W !?5,"Please choose another division." 154 S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE 155 I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV 156 CONT ; continue 157 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 158 S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^") 159 I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE 160 G ^DGREG0 161 PR2 W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG 162 PR3 W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG 163 H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1 164 Q K DG,DQ G Q1^DGREG0 165 Q1 K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q 166 EL S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q 167 S DR=DR_"HUMANITARIAN EMERGENCY" Q 168 FEE S DGRPFEE=1 D DGREG K DGRPFEE G Q1 169 ; 170 WARN I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2 171 I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2 172 Q 173 MSG W !,"Another user is editing, try later ..." G Q 174 ; 175 BEGINREG(DFN) ; 176 ;Description: This is called at the beginning of the registration process. 177 ;Concurrent processes can check the lock to determine if the patient is 178 ;currently being registered. 179 ; 180 Q:'$G(DFN) 0 181 I $$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!! 182 L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1 183 I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record 184 Q 185 ; 186 ENDREG(DFN) ; 187 ;Description: releases the lock obtained by calling BEGINREG. 188 ; 189 Q:'$G(DFN) 190 L -^TMP(DFN,"REGISTRATION IN PROGRESS") 191 D UNLOCK^DGENPTA1(DFN) 192 Q 193 ; 194 IFREG(DFN) ; 195 ;Description: tests whether the lock set by BEGINREG is set 196 ; 197 ;Input: DFN 198 ;Output: 199 ; Function Value = 1 if lock is set, 0 otherwise 200 ; 201 N RETURN 202 Q:'$G(DFN) 0 203 L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1 204 S RETURN='$T 205 L -^TMP(DFN,"REGISTRATION IN PROGRESS") 206 Q RETURN 207 Q 208 CIRN ;MPI QUERY 209 ;check to see if CIRN PD/MPI is installed 210 N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T 211 K MPIFRTN 212 D MPIQ^MPIFAPI(DFN) 213 K MPIFRTN 214 Q 215 ROMQRY ; 216 I +$G(DGNEW) D 217 . ; query LST for Patient Demographic Information if NEW patient and 218 . ; file into patient's record. 219 . N A 220 . I $$ROMQRY^DGROAPI(DFN) D 221 . . ;display busy message to interactive users 222 . .S DGMSG(1)="Data retrieval from LST site has been completed successfully" 223 . .S DGMSG(2)="Thank you for your patience." 224 . .D EN^DDIOL(.DGMSG) R A:5 225 . E D 226 . . ;display busy message to interactive users 227 . .S DGMSG(1)="Data retrieval from LST site has not been successful." 228 . .S DGMSG(2)="Please continue the Registration Process." 229 . .D EN^DDIOL(.DGMSG) R A:5 230 . ; 231 Q
Note:
See TracChangeset
for help on using the changeset viewer.
