DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 8/6/04 3:17pm
;;5.3;Registration;**108,121,161,151,459,604,1015**;Aug 13, 1993;Build 21
;
D LO^DGUTL
GETL S L=^DG(43,1,0),DISL=+$P(L,"^",7) S:DISL=0 DISL=24 N SDISHDL
FIND 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
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
DP W !!,"LOG DATE",?20,"TYPE OF BENEFIT APPLIED FOR",! F I=1:1:47 W "-"
S L2=";"_$P(^DD(2.101,2,0),"^",3),L3=";"_$P(L,"^",3)_":"
W !,$$FMTE^XLFDT($E($P(L,U),1,12),"5Z"),?20,$P($P(L2,L3,2),";",1)
S DGODSND=L
ANS ;
;** DG*5.3*108; Eligibility Code and Period of Service Checks follow
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
N DGPOSX,DGELIGX,DGSTRX
S DGELIGX=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0)
S DGPOSX=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0)
I (DGELIGX)&(DGPOSX) W !!,"Primary Eligibility Code and Period of Service are unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL
I (DGELIGX)&('DGPOSX) W !!,"Primary Eligibility Code is unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL
I ('DGELIGX)&(DGPOSX) W !!,"Period of Service is unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL
;S DGXXXD=0 D EL^DGREGE
DISP 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
D ODS
S DR="" I $P(Y(0),"^",1)["INELIG" S DIE("NO^")="",DR="2.1;"
S DR=DR_"S:'DGODS Y=6;11500.01////1;11500.02////^S X=$S(DGODSE>0:DGODSE,1:"""");"
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=""
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
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)
S DFN=DGDFN,DFN1=DGDFN1,DGXXXD=0,DIE="^DPT("_DFN_",""DIS""," D EL^DGREGE
D MT
D EN1^DGEN(DFN) ;enrollment
W !!,"***** Registration dispositioned *****",!!,*7
D VALIDATE(DFN,DFN1) ; -- call c/o validator
D ACT
K DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
DONE D Q G FIND
;
Q 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
K DGODS,DGODSND,SDISDEL Q
;
CHT 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
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
S Y=$S(DUZ'="":9,1:0) S:X3'<DISL Y=8,DGL=1 Q
;
DEL 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)
I $P($G(^DPT(DFN,"DIS",DFN1,0)),"^",18) D EN^SDCODEL(+$P(^(0),"^",18),1,$G(SDISHDL))
D Q W !!,"* Disposition deleted *",!!,*7,*7 G FIND
;
ODS ;if operation desert shield admission, create an entry in the ODS ADMISSIONS file
N DIE,DGDISTYP
S DGODS=0,DGDISTYP=+Y
I $P(Y(0),"^",1)["ADMIT"!($P(Y(0),"^",1)["ADMISSION"&($P(Y(0),"^",1)'["SCHEDULED")) Q ;don't store dispositions to admit
N Y D PT^DGYZODS I 'DGODS Q
S A1B2FL=11500.4,A1B2DT=+DGODSND D ADD^A1B2UTL S (DA,DGODSE)=+Y
S DIE="^A1B2(11500.4,",DR=".02////^S X=DGODS;.05////^S X=DGDISTYP;" D ^DIE
K DIE,DA Q
;
MT ;Check if user requires a means test. Ask user if s/he wants to
;proceed if one is required.
N DGREQF
D EN^DGMTR
I $P($$MTS^DGMTU(DFN),U,2)="R" D EDT^DGMTU(DFN,DT)
Q
;
ACT ;Execute Program Action
N DFN1
S DGDFN=DFN I $D(^DIC(37,DISP,"P")),^("P")]"" X ^("P")
Q
;
BEFORE(DFN,SDDT,SDEVT,SDISHDL) ; -- set 'before' vars for opt evt drv
; -- use tag for NEWing
N DA,DFN1,DGDFN,DGDFN1,DGODSND
D BEFORE^SDAMEVT3(.DFN,.SDDT,.SDEVT,.SDISHDL)
Q
;
EVT(DFN,SDDT,SDEVT,SDISHDL) ; -- opt evt drv
; -- use tag for NEWing
N DIV,DFN1,DGDFN,SDL,DGDIV,DISP,SD321,SDDIV,I,DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
D EVT^SDAMEVT3(.DFN,.SDDT,.SDEVT,.SDISHDL)
Q
;
VALIDATE(DFN,DFN1) ; -- c/o validator
; -- use tag for NEWing
N DIV,DGDFN,SDL,DGDIV,DISP,SD321,SDDIV,I,DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
;
N DGDIS0,DGOE,DGOE0,DGVST
S DGDIS0=$G(^DPT(+DFN,"DIS",+DFN1,0))
I "^0^1^"[(U_$P(DGDIS0,"^",2)_U) D
. ;
. ; -- get encounter
. S DGOE=+$P(DGDIS0,U,18)
. IF 'DGOE Q
. ;
. ; -- get encounter and visit
. S DGOE0=$$GETOE^SDOE(DGOE)
. S DGVST=+$P(DGOE0,U,5)
. IF 'DGVST Q
. ;
. ; -- validate disposition
. D FINAL^SCDXHLDR(DGVST)
Q
DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 8/6/04 3:17pm
+1 ;;5.3;Registration;**108,121,161,151,459,604,1015**;Aug 13, 1993;Build 21
+2 ;
+3 DO LO^DGUTL
GETL SET L=^DG(43,1,0)
SET DISL=+$PIECE(L,"^",7)
IF DISL=0
SET DISL=24
NEW SDISHDL
FIND WRITE !!
SET DIC("A")="Disposition PATIENT: "
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
SET DIC("S")="I $D(^DPT(""ADA"",1,+Y))"
DO ^DIC
KILL DIC("S"),DIC("A")
IF Y'>0
GOTO Q
SET (DA,DFN,DGDFN)=+Y
+1 ;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
SET I=+$ORDER(^DPT(DA,"DIS",0))
SET L=$SELECT($DATA(^(I,0)):^(0),1:"")
SET (DA,DFN1,DGDFN1)=I
SET SDL=L
DP WRITE !!,"LOG DATE",?20,"TYPE OF BENEFIT APPLIED FOR",!
FOR I=1:1:47
WRITE "-"
+1 SET L2=";"_$PIECE(^DD(2.101,2,0),"^",3)
SET L3=";"_$PIECE(L,"^",3)_":"
+2 WRITE !,$$FMTE^XLFDT($EXTRACT($PIECE(L,U),1,12),"5Z"),?20,$PIECE($PIECE(L2,L3,2),";",1)
+3 SET DGODSND=L
ANS ;
+1 ;** DG*5.3*108; Eligibility Code and Period of Service Checks follow
+2 WRITE !!
SET DR="1;2;2.1;13;5//NOW;D CHT^DGDIS;8"_$SELECT(DUZ'="":";9////"_DUZ,1:"")
SET DIE="^DPT("_DFN_",""DIS"","
SET DA(1)=DFN
SET DP=2.101
DO ^DIE
IF $SELECT('$DATA(^DPT(DFN,"DIS",DA,0)):1,'$PIECE(^(0),"^",6):1,1:0)
GOTO DEL
+3 NEW DGPOSX,DGELIGX,DGSTRX
+4 SET DGELIGX=$SELECT('$DATA(^DPT(DFN,.36)):1,$PIECE(^(.36),"^",1)']"":1,1:0)
+5 SET DGPOSX=$SELECT('$DATA(^DPT(DFN,.32)):1,$PIECE(^(.32),"^",3)']"":1,1:0)
+6 IF (DGELIGX)&(DGPOSX)
WRITE !!,"Primary Eligibility Code and Period of Service are unspecified."
KILL DGPOSX,DGELIGX,DGSTRX
GOTO DEL
+7 IF (DGELIGX)&('DGPOSX)
WRITE !!,"Primary Eligibility Code is unspecified."
KILL DGPOSX,DGELIGX,DGSTRX
GOTO DEL
+8 IF ('DGELIGX)&(DGPOSX)
WRITE !!,"Period of Service is unspecified."
KILL DGPOSX,DGELIGX,DGSTRX
GOTO DEL
+9 ;S DGXXXD=0 D EL^DGREGE
DISP WRITE !
SET DIC="^DIC(37,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select the type of disposition: "
SET DIC("S")="I '$P(^(0),""^"",10)"
DO ^DIC
KILL DIC("A"),DIC("B")
IF Y'>0
IF X?1"^".E
GOTO DEL
WRITE !!,"A disposition must be entered to continue.",!!,*7,*7
GOTO DISP
+1 DO ODS
+2 SET DR=""
IF $PIECE(Y(0),"^",1)["INELIG"
SET DIE("NO^")=""
SET DR="2.1;"
+3 SET DR=DR_"S:'DGODS Y=6;11500.01////1;11500.02////^S X=$S(DGODSE>0:DGODSE,1:"""");"
+4 SET DR=DR_"6///"_(+Y)
SET DISP=+Y
SET DA=DFN1
SET DP=2.101
SET DA(1)=DFN
DO ^DIE
KILL DIE("NO^")
SET DDT=$SELECT($DATA(^DPT(DFN,"DIS",DA,0)):^(0),1:"")
SET DGDIV=+$PIECE(DDT,"^",4)
SET DDT=$PIECE(DDT,"^",6)
IF 'DGDIV
SET DGDIV=""
+5 IF $PIECE(^DG(43,1,0),U,30)
SET %ZIS="N"
SET IOP="HOME"
DO ^%ZIS
IF $DATA(IOS)
IF IOS
IF $DATA(^%ZIS(1,+IOS,99))
IF $DATA(^%ZIS(1,+^(99),0))
SET Y=$PIECE(^(0),U,1)
SET DGIO(10)=Y
+6 SET X=$SELECT($DATA(^DG(40.8,+DGDIV,"DEV")):^("DEV"),1:"1^1^1")
IF '$DATA(DGIO(10))
SET DGIO(10)=$SELECT($PIECE(X,U,1)]"":$PIECE(X,U,1),1:1)
+7 SET DFN=DGDFN
SET DFN1=DGDFN1
SET DGXXXD=0
SET DIE="^DPT("_DFN_",""DIS"","
DO EL^DGREGE
+8 DO MT
+9 ;enrollment
DO EN1^DGEN(DFN)
+10 WRITE !!,"***** Registration dispositioned *****",!!,*7
+11 ; -- call c/o validator
DO VALIDATE(DFN,DFN1)
+12 DO ACT
+13 KILL DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
DONE DO Q
GOTO FIND
+1 ;
Q KILL %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
+1 KILL DGODS,DGODSND,SDISDEL
QUIT
+2 ;
CHT SET L=^DPT(DA(1),"DIS",DA,0)
SET DGL=0
SET L2=+$PIECE(L,"^",6)
SET (L1,X)=+L
DO H^%DTC
SET LL1=%H
SET X=L2
DO H^%DTC
SET LL2=%H
+1 SET X1=L1#1*10000
SET X2=L2#1*10000
IF LL2-LL1
SET X2=X2+(LL2-LL1*2400\1)
SET X3=X2\100-(X1\100)
SET X2=X2#100
SET X1=X1#100
IF X1'<X2
SET X2=X2+60
SET X3=X3-1
+2 SET Y=$SELECT(DUZ'="":9,1:0)
IF X3'<DISL
SET Y=8
SET DGL=1
QUIT
+3 ;
DEL SET L=$SELECT($DATA(^DPT(DFN,"DIS",DFN1,0)):^(0),1:0)
SET X=$PIECE(L,U,6)
IF X
SET $PIECE(^(0),U,6)=""
FOR I=0:0
SET I=$ORDER(^DD(2.101,5,1,I))
IF 'I
QUIT
XECUTE ^(I,2)
+1 IF $PIECE($GET(^DPT(DFN,"DIS",DFN1,0)),"^",18)
DO EN^SDCODEL(+$PIECE(^(0),"^",18),1,$GET(SDISHDL))
+2 DO Q
WRITE !!,"* Disposition deleted *",!!,*7,*7
GOTO FIND
+3 ;
ODS ;if operation desert shield admission, create an entry in the ODS ADMISSIONS file
+1 NEW DIE,DGDISTYP
+2 SET DGODS=0
SET DGDISTYP=+Y
+3 ;don't store dispositions to admit
IF $PIECE(Y(0),"^",1)["ADMIT"!($PIECE(Y(0),"^",1)["ADMISSION"&($PIECE(Y(0),"^",1)'["SCHEDULED"))
QUIT
+4 NEW Y
DO PT^DGYZODS
IF 'DGODS
QUIT
+5 SET A1B2FL=11500.4
SET A1B2DT=+DGODSND
DO ADD^A1B2UTL
SET (DA,DGODSE)=+Y
+6 SET DIE="^A1B2(11500.4,"
SET DR=".02////^S X=DGODS;.05////^S X=DGDISTYP;"
DO ^DIE
+7 KILL DIE,DA
QUIT
+8 ;
MT ;Check if user requires a means test. Ask user if s/he wants to
+1 ;proceed if one is required.
+2 NEW DGREQF
+3 DO EN^DGMTR
+4 IF $PIECE($$MTS^DGMTU(DFN),U,2)="R"
DO EDT^DGMTU(DFN,DT)
+5 QUIT
+6 ;
ACT ;Execute Program Action
+1 NEW DFN1
+2 SET DGDFN=DFN
IF $DATA(^DIC(37,DISP,"P"))
IF ^("P")]""
XECUTE ^("P")
+3 QUIT
+4 ;
BEFORE(DFN,SDDT,SDEVT,SDISHDL) ; -- set 'before' vars for opt evt drv
+1 ; -- use tag for NEWing
+2 NEW DA,DFN1,DGDFN,DGDFN1,DGODSND
+3 DO BEFORE^SDAMEVT3(.DFN,.SDDT,.SDEVT,.SDISHDL)
+4 QUIT
+5 ;
EVT(DFN,SDDT,SDEVT,SDISHDL) ; -- opt evt drv
+1 ; -- use tag for NEWing
+2 NEW DIV,DFN1,DGDFN,SDL,DGDIV,DISP,SD321,SDDIV,I,DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
+3 DO EVT^SDAMEVT3(.DFN,.SDDT,.SDEVT,.SDISHDL)
+4 QUIT
+5 ;
VALIDATE(DFN,DFN1) ; -- c/o validator
+1 ; -- use tag for NEWing
+2 NEW DIV,DGDFN,SDL,DGDIV,DISP,SD321,SDDIV,I,DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP
+3 ;
+4 NEW DGDIS0,DGOE,DGOE0,DGVST
+5 SET DGDIS0=$GET(^DPT(+DFN,"DIS",+DFN1,0))
+6 IF "^0^1^"[(U_$PIECE(DGDIS0,"^",2)_U)
Begin DoDot:1
+7 ;
+8 ; -- get encounter
+9 SET DGOE=+$PIECE(DGDIS0,U,18)
+10 IF 'DGOE
QUIT
+11 ;
+12 ; -- get encounter and visit
+13 SET DGOE0=$$GETOE^SDOE(DGOE)
+14 SET DGVST=+$PIECE(DGOE0,U,5)
+15 IF 'DGVST
QUIT
+16 ;
+17 ; -- validate disposition
+18 DO FINAL^SCDXHLDR(DGVST)
End DoDot:1
+19 QUIT
