source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMVODS.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 1.5 KB
RevLine 
[613]1DGPMVODS ;ALB/MIR - ODS TRANSACTIONS FOR ADMIT AND DISCHARGE ; 16 JAN 91
2 ;;5.3;Registration;;Aug 13, 1993
3 ;;VERSION
4 ;
5 ;
6NEW ;Determine if ODS software is on and, if so, make sure period of service is defined
7 ;
8 D ON^DGYZODS S DGODSON=DGODS I 'DGODS Q
9 I $D(^DPT(DFN,.32)),$D(^DIC(21,+$P(^(.32),"^",3),0)) Q
10 W !!,"Entry of Eligibility Code and Period of Service is required to continue.",!
11 S DIE="^DPT(",DA=DFN
12 S DR=".361;.323;D ^DGYZODS;S:'DGODS Y="""";11500.02;11500.03" D ^DIE
13 Q
14 ;
15 ;
16 ;
17ADM ;if operation desert shield admission, create an entry in the ODS ADMISSIONS file
18 N DA D PT^DGYZODS I 'DGODS Q
19 S DGSPEC=$O(^DGPM("APHY",DGPMDA,0)),DGSPEC=$S($D(^DGPM(+DGSPEC,0)):$P(^(0),"^",9),1:""),DGSPEC=$S($D(^DIC(45.7,+DGSPEC,0)):$P(^(0),"^",2),1:"")
20 S A1B2FL=11500.2,A1B2DT=+DGPMA D ADD^A1B2UTL S (DA,DGODSE)=+Y
21 S DIE="^A1B2(11500.2,",DR=".02////^S X=DGODS;.03////^S X=DGSPEC" D ^DIE
22 S DIE="^DGPM(",DA=DGPMDA,DR="11500.04////"_DGODSE D ^DIE
23 K DGSPEC,DIE Q
24 ;
25 ;
26 ;
27DIS ;check for displace patients...create new entry if necessary
28 N DIE,DA
29 S DGODSPT=$S($D(^DGPM(DGPMDA,"ODS")):^("ODS"),1:"") I '$P(DGODSPT,"^",5) Q
30 I $P(DGODSPT,"^",7) Q ;Q if already stored in file
31 D PT1^DGYZODS I 'DGODS Q
32 S A1B2FL=11500.3,A1B2DT=+DGPMA I 'A1B2DT Q
33 D ADD^A1B2UTL S (DA,DGODSE)=+Y
34 S DIE="^A1B2(11500.3,",DR=".02////^S X=DGODS;.03////^S X=$P(DGODSPT,""^"",6);.1////^S X=$S($D(^DIC(4,+$P(DGPMA,""^"",5),0)):$P(^(0),""^"",1),1:"""");.11////^S X=$P(DGODSPT,""^"",2)" D ^DIE
35 S DIE="^DGPM(",DA=DGPMDA,DR="11500.07////"_DGODSE D ^DIE
36 K DGODSPT Q
Note: See TracBrowser for help on using the repository browser.