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

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 8/6/04 3:17pm
2 ;;5.3;Registration;**108,121,161,151,459,604**;Aug 13, 1993
3 ;
4 D LO^DGUTL
5GETL S L=^DG(43,1,0),DISL=+$P(L,"^",7) S:DISL=0 DISL=24 N SDISHDL
6FIND W !! S DIC("A")="Disposition PATIENT: ",DIC="^DPT(",DIC(0)="AEQMZ",DIC("S")="I $D(^DPT(""ADA"",1,+Y))" D ^DIC K DIC("S"),DIC("A") G Q:Y'>0 S (DA,DFN,DGDFN)=+Y
7 S I=+$O(^DPT(DA,"DIS",0)),L=$S($D(^(I,0)):^(0),1:""),(DA,DFN1,DGDFN1)=I,SDL=L ;I $P(L,"^",6)?7N.E!(L="") W !!,"There are no open registrations to disposition for this patient.",!!,*7,*7 K DA,DFN1 G FIND
8DP W !!,"LOG DATE",?20,"TYPE OF BENEFIT APPLIED FOR",! F I=1:1:47 W "-"
9 S L2=";"_$P(^DD(2.101,2,0),"^",3),L3=";"_$P(L,"^",3)_":"
10 W !,$$FMTE^XLFDT($E($P(L,U),1,12),"5Z"),?20,$P($P(L2,L3,2),";",1)
11 S DGODSND=L
12ANS ;
13 ;** DG*5.3*108; Eligibility Code and Period of Service Checks follow
14 W !! S DR="1;2;2.1;13;5//NOW;D CHT^DGDIS;8"_$S(DUZ'="":";9////"_DUZ,1:""),DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DP=2.101 D ^DIE I $S('$D(^DPT(DFN,"DIS",DA,0)):1,'$P(^(0),"^",6):1,1:0) G DEL
15 N DGPOSX,DGELIGX,DGSTRX
16 S DGELIGX=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0)
17 S DGPOSX=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0)
18 I (DGELIGX)&(DGPOSX) W !!,"Primary Eligibility Code and Period of Service are unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL
19 I (DGELIGX)&('DGPOSX) W !!,"Primary Eligibility Code is unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL
20 I ('DGELIGX)&(DGPOSX) W !!,"Period of Service is unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL
21 ;S DGXXXD=0 D EL^DGREGE
22DISP W ! S DIC="^DIC(37,",DIC(0)="AEQMZ",DIC("A")="Select the type of disposition: ",DIC("S")="I '$P(^(0),""^"",10)" D ^DIC K DIC("A"),DIC("B") I Y'>0 G DEL:X?1"^".E W !!,"A disposition must be entered to continue.",!!,*7,*7 G DISP
23 D ODS
24 S DR="" I $P(Y(0),"^",1)["INELIG" S DIE("NO^")="",DR="2.1;"
25 S DR=DR_"S:'DGODS Y=6;11500.01////1;11500.02////^S X=$S(DGODSE>0:DGODSE,1:"""");"
26 S DR=DR_"6///"_(+Y),DISP=+Y,DA=DFN1,DP=2.101,DA(1)=DFN D ^DIE K DIE("NO^") S DDT=$S($D(^DPT(DFN,"DIS",DA,0)):^(0),1:""),DGDIV=+$P(DDT,"^",4),DDT=$P(DDT,"^",6) S:'DGDIV DGDIV=""
27 I $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),DGIO(10)=Y
28 S X=$S($D(^DG(40.8,+DGDIV,"DEV")):^("DEV"),1:"1^1^1") S:'$D(DGIO(10)) DGIO(10)=$S($P(X,U,1)]"":$P(X,U,1),1:1)
29 S DFN=DGDFN,DFN1=DGDFN1,DGXXXD=0,DIE="^DPT("_DFN_",""DIS""," D EL^DGREGE
30 D MT
31 D EN1^DGEN(DFN) ;enrollment
32 W !!,"***** Registration dispositioned *****",!!,*7
33 D VALIDATE(DFN,DFN1) ; -- call c/o validator
34 D ACT
35 K DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
36DONE D Q G FIND
37 ;
38Q K %H,%Y,C,D0,D1,DG1,DGA1,DGDFN1,DGL,DGT,DQ,I1,SD321,SDDIV,SDL,VA,VAROOT,Z,DGDFN,DIC,DGIO,DDT,DISP,DGDIV,DA,DR,DFN,DFN1,L,I,Y,X,DIE,DIC,DP
39 K DGODS,DGODSND,SDISDEL Q
40 ;
41CHT S L=^DPT(DA(1),"DIS",DA,0),DGL=0,L2=+$P(L,"^",6),(L1,X)=+L D H^%DTC S LL1=%H,X=L2 D H^%DTC S LL2=%H
42 S X1=L1#1*10000,X2=L2#1*10000 S:LL2-LL1 X2=X2+(LL2-LL1*2400\1) S X3=X2\100-(X1\100),X2=X2#100,X1=X1#100 S:X1'<X2 X2=X2+60,X3=X3-1
43 S Y=$S(DUZ'="":9,1:0) S:X3'<DISL Y=8,DGL=1 Q
44 ;
45DEL S L=$S($D(^DPT(DFN,"DIS",DFN1,0)):^(0),1:0),X=$P(L,U,6) I X S $P(^(0),U,6)="" F I=0:0 S I=$O(^DD(2.101,5,1,I)) Q:'I X ^(I,2)
46 I $P($G(^DPT(DFN,"DIS",DFN1,0)),"^",18) D EN^SDCODEL(+$P(^(0),"^",18),1,$G(SDISHDL))
47 D Q W !!,"* Disposition deleted *",!!,*7,*7 G FIND
48 ;
49ODS ;if operation desert shield admission, create an entry in the ODS ADMISSIONS file
50 N DIE,DGDISTYP
51 S DGODS=0,DGDISTYP=+Y
52 I $P(Y(0),"^",1)["ADMIT"!($P(Y(0),"^",1)["ADMISSION"&($P(Y(0),"^",1)'["SCHEDULED")) Q ;don't store dispositions to admit
53 N Y D PT^DGYZODS I 'DGODS Q
54 S A1B2FL=11500.4,A1B2DT=+DGODSND D ADD^A1B2UTL S (DA,DGODSE)=+Y
55 S DIE="^A1B2(11500.4,",DR=".02////^S X=DGODS;.05////^S X=DGDISTYP;" D ^DIE
56 K DIE,DA Q
57 ;
58MT ;Check if user requires a means test. Ask user if s/he wants to
59 ;proceed if one is required.
60 N DGREQF
61 D EN^DGMTR
62 I $P($$MTS^DGMTU(DFN),U,2)="R" D EDT^DGMTU(DFN,DT)
63 Q
64 ;
65ACT ;Execute Program Action
66 N DFN1
67 S DGDFN=DFN I $D(^DIC(37,DISP,"P")),^("P")]"" X ^("P")
68 Q
69 ;
70BEFORE(DFN,SDDT,SDEVT,SDISHDL) ; -- set 'before' vars for opt evt drv
71 ; -- use tag for NEWing
72 N DA,DFN1,DGDFN,DGDFN1,DGODSND
73 D BEFORE^SDAMEVT3(.DFN,.SDDT,.SDEVT,.SDISHDL)
74 Q
75 ;
76EVT(DFN,SDDT,SDEVT,SDISHDL) ; -- opt evt drv
77 ; -- use tag for NEWing
78 N DIV,DFN1,DGDFN,SDL,DGDIV,DISP,SD321,SDDIV,I,DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
79 D EVT^SDAMEVT3(.DFN,.SDDT,.SDEVT,.SDISHDL)
80 Q
81 ;
82VALIDATE(DFN,DFN1) ; -- c/o validator
83 ; -- use tag for NEWing
84 N DIV,DGDFN,SDL,DGDIV,DISP,SD321,SDDIV,I,DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
85 ;
86 N DGDIS0,DGOE,DGOE0,DGVST
87 S DGDIS0=$G(^DPT(+DFN,"DIS",+DFN1,0))
88 I "^0^1^"[(U_$P(DGDIS0,"^",2)_U) D
89 . ;
90 . ; -- get encounter
91 . S DGOE=+$P(DGDIS0,U,18)
92 . IF 'DGOE Q
93 . ;
94 . ; -- get encounter and visit
95 . S DGOE0=$$GETOE^SDOE(DGOE)
96 . S DGVST=+$P(DGOE0,U,5)
97 . IF 'DGVST Q
98 . ;
99 . ; -- validate disposition
100 . D FINAL^SCDXHLDR(DGVST)
101 Q
Note: See TracBrowser for help on using the repository browser.