DGREGE ;ALB/JDS - EDIT REGISTRATIONS/DISPOSITIONS ; 04/30/2004
;;5.3;Registration;**24,161,151,459,568**;Aug 13, 1993
N SDISHDL
A W !! S DIC=2,DIC(0)="AEQM" D ^DIC K DIC G Q:Y<0 S (DFN,DA)=+Y
I '$O(^DPT(DA,"DIS",0)) W !!,"No registrations to print from.",!! G A
F11 R !!,"Registration date/time: ",X:DTIME G A:'$T!(X?1"^".E)!(X=""),NUM:$L(X)<7 S %DT="T" D ^%DT S DFN1=9999999-Y G W1:$D(^DPT(DA,"DIS",DFN1)) W !!
HELP W ! S J=0 F I=0:0 S I=$O(^DPT(DA,"DIS",I)) Q:'I S J=J+1,L=+(^(I,0))_"00000" W $J(J,2),". ",$$FMTE^XLFDT($E(L,1,12),"5Z") W ?$X\40+1*40 W:$X>75 ! Q:J>20
W !,"Enter the date and time, Entry #, or 'L' for the last registration,",!," to select the registration you wish to edit" G F11
NUM ; choose by number of find last registration
S DFN1=0
I X="L" S DFN1=$O(^DPT(DA,"DIS",0)) ; get last
F I=1:1:+X S DFN1=$O(^DPT(DA,"DIS",DFN1)) Q:'DFN1
G HELP:'DFN1
W " ",$$FMTE^XLFDT(9999999-DFN1,"5Z"),!!
W1 S DA=DFN1,DA(1)=DFN,L=$G(^DPT(DFN,"DIS",DFN1,0)),DP=2.101,DR=$S($P(L,U,6):"[DGREGE]",1:"[DGREGEO]")
I $P(L,U,18) S (SDISHDL,^TMP("SDEVT HANDLE",$J))=$G(^TMP("SDEVT HANDLE",$J))+1 D BEFORE^DGDIS(DFN,9999999-DFN1,9,SDISHDL)
S DIE="^DPT(",DA=DFN D ^DIE K DE,DQ,DIE,DR S DIE="^DPT("_DFN_",""DIS"",",DGXXXD=0 D EL
N DGL
S DGL=$G(^DPT(DFN,"DIS",DFN1,0))
I $P(DGL,U,18) D
. I "^0^1^"[(U_$P(DGL,U,2)_U),$P(DGL,U,6) D CO(DFN,9999999-DFN1,SDISHDL)
. D EVT^DGDIS(DFN,9999999-DFN1,9,SDISHDL)
. D VALIDATE^DGDIS(DFN,DFN1) ; -- call c/o validator
G A
;
Q K %,%H,%X,%Y,C,D0,D1,DA,DFN,DFN1,DIE,DP,I,J,L,X,Y
Q
;
DT I Y X ^DD("DD") W Y
Q
EL W !!,"Updating eligibility status for this registration...",!
S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DGXXX=$S($D(^DPT(DFN,.361)):$P(^(.361),"^",1),1:""),DGXXX1=$S($D(^DPT(DFN,"DIS",DFN1,0)):^(0),1:"") Q:'DGXXX1 S DGXXX2=+$P(DGXXX1,"^",13),DR="14///"_$S(DGXXX="V":1,1:0)
I $D(^DIC(8,DGXXX2,0)),$P(^(0),"^",5)="Y",$P(^(0),"^",4)=1!($P(^(0),"^",4)=3) S DGXXX3=$S($D(^DPT(DFN,.3)):$P(^(.3),"^",2),1:""),DR=DR_";15///1;16//"_DGXXX3
E S DR=DR_";15///NO"
S:$P(DGXXX1,"^",17) DR=DR_";17///@" D ^DIE G ELQ:DGXXXD
S DGXXXD=0 D SEG^DGA4004 I DGSEG W !!,"Disposition on AMIS Segment ",DGSEG," - ",$S($D(^DG(391.1,+DGSEG,0)):$P(^(0),"^",1),1:"SEGMENT NAME UNKNOWN") K DR S DR="17///"_DGSEG D ^DIE K DE,DQ,DIE,DR
E W !!,"Patient falls into a means test category...AMIS 401-420 segment will be",!,"determined at time the report is generated..."
ELQ W ! K DGXXX,DGXXX1,DGXXX2,DGXXX3,DGXXXD,DR,DIE("NO^"),DGSEG Q
;
CO(DFN,SDDT,SDISHDL) ; -- ask check out questions
N DFN1,SDCOQUIT,SDIS,SDOE,SDPMTDF
S SDOE=$$GETDISP^SDVSIT2(DFN,SDDT) G COQ:'SDOE
S SDIS=$G(^DPT(DFN,"DIS",9999999-SDDT,0))
I '$$SCE^DGSDU(+SDOE,7,0)!($P($G(^TMP("SDEVT",$J,SDISHDL,3,"DIS",0,"BEFORE")),"^",13)'=$P(SDIS,"^",13)) D INT^SDCO6(SDOE,.SDCOQUIT)
I '$D(SDCOQUIT) D
.S SDPMTDF=$S($P(^DG(43,1,0),"^",32):1,$P($G(^DIC(37,+$P(SDIS,"^",7),0)),"^")="SCHEDULE FUTURE APPOINTMENT":1,1:0)
. I $$ASK^SDCO6(SDPMTDF) D EN^SDCO(SDOE,SDISHDL,1)
COQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGREGE 3021 printed Oct 16, 2024@18:55:33 Page 2
DGREGE ;ALB/JDS - EDIT REGISTRATIONS/DISPOSITIONS ; 04/30/2004
+1 ;;5.3;Registration;**24,161,151,459,568**;Aug 13, 1993
+2 NEW SDISHDL
A WRITE !!
SET DIC=2
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET (DFN,DA)=+Y
+1 IF '$ORDER(^DPT(DA,"DIS",0))
WRITE !!,"No registrations to print from.",!!
GOTO A
F11 READ !!,"Registration date/time: ",X:DTIME
if '$TEST!(X?1"^".E)!(X="")
GOTO A
if $LENGTH(X)<7
GOTO NUM
SET %DT="T"
DO ^%DT
SET DFN1=9999999-Y
if $DATA(^DPT(DA,"DIS",DFN1))
GOTO W1
WRITE !!
HELP WRITE !
SET J=0
FOR I=0:0
SET I=$ORDER(^DPT(DA,"DIS",I))
if 'I
QUIT
SET J=J+1
SET L=+(^(I,0))_"00000"
WRITE $JUSTIFY(J,2),". ",$$FMTE^XLFDT($EXTRACT(L,1,12),"5Z")
WRITE ?$X\40+1*40
if $X>75
WRITE !
if J>20
QUIT
+1 WRITE !,"Enter the date and time, Entry #, or 'L' for the last registration,",!," to select the registration you wish to edit"
GOTO F11
NUM ; choose by number of find last registration
+1 SET DFN1=0
+2 ; get last
IF X="L"
SET DFN1=$ORDER(^DPT(DA,"DIS",0))
+3 FOR I=1:1:+X
SET DFN1=$ORDER(^DPT(DA,"DIS",DFN1))
if 'DFN1
QUIT
+4 if 'DFN1
GOTO HELP
+5 WRITE " ",$$FMTE^XLFDT(9999999-DFN1,"5Z"),!!
W1 SET DA=DFN1
SET DA(1)=DFN
SET L=$GET(^DPT(DFN,"DIS",DFN1,0))
SET DP=2.101
SET DR=$SELECT($PIECE(L,U,6):"[DGREGE]",1:"[DGREGEO]")
+1 IF $PIECE(L,U,18)
SET (SDISHDL,^TMP("SDEVT HANDLE",$JOB))=$GET(^TMP("SDEVT HANDLE",$JOB))+1
DO BEFORE^DGDIS(DFN,9999999-DFN1,9,SDISHDL)
+2 SET DIE="^DPT("
SET DA=DFN
DO ^DIE
KILL DE,DQ,DIE,DR
SET DIE="^DPT("_DFN_",""DIS"","
SET DGXXXD=0
DO EL
+3 NEW DGL
+4 SET DGL=$GET(^DPT(DFN,"DIS",DFN1,0))
+5 IF $PIECE(DGL,U,18)
Begin DoDot:1
+6 IF "^0^1^"[(U_$PIECE(DGL,U,2)_U)
IF $PIECE(DGL,U,6)
DO CO(DFN,9999999-DFN1,SDISHDL)
+7 DO EVT^DGDIS(DFN,9999999-DFN1,9,SDISHDL)
+8 ; -- call c/o validator
DO VALIDATE^DGDIS(DFN,DFN1)
End DoDot:1
+9 GOTO A
+10 ;
Q KILL %,%H,%X,%Y,C,D0,D1,DA,DFN,DFN1,DIE,DP,I,J,L,X,Y
+1 QUIT
+2 ;
DT IF Y
XECUTE ^DD("DD")
WRITE Y
+1 QUIT
EL WRITE !!,"Updating eligibility status for this registration...",!
+1 SET DA=DFN1
SET DIE("NO^")=""
SET DA(1)=DFN
SET DP=2.101
SET DGXXX=$SELECT($DATA(^DPT(DFN,.361)):$PIECE(^(.361),"^",1),1:"")
SET DGXXX1=$SELECT($DATA(^DPT(DFN,"DIS",DFN1,0)):^(0),1:"")
if 'DGXXX1
QUIT
SET DGXXX2=+$PIECE(DGXXX1,"^",13)
SET DR="14///"_$SELECT(DGXXX="V":1,1:0)
+2 IF $DATA(^DIC(8,DGXXX2,0))
IF $PIECE(^(0),"^",5)="Y"
IF $PIECE(^(0),"^",4)=1!($PIECE(^(0),"^",4)=3)
SET DGXXX3=$SELECT($DATA(^DPT(DFN,.3)):$PIECE(^(.3),"^",2),1:"")
SET DR=DR_";15///1;16//"_DGXXX3
+3 IF '$TEST
SET DR=DR_";15///NO"
+4 if $PIECE(DGXXX1,"^",17)
SET DR=DR_";17///@"
DO ^DIE
if DGXXXD
GOTO ELQ
+5 SET DGXXXD=0
DO SEG^DGA4004
IF DGSEG
WRITE !!,"Disposition on AMIS Segment ",DGSEG," - ",$SELECT($DATA(^DG(391.1,+DGSEG,0)):$PIECE(^(0),"^",1),1:"SEGMENT NAME UNKNOWN")
KILL DR
SET DR="17///"_DGSEG
DO ^DIE
KILL DE,DQ,DIE,DR
+6 IF '$TEST
WRITE !!,"Patient falls into a means test category...AMIS 401-420 segment will be",!,"determined at time the report is generated..."
ELQ WRITE !
KILL DGXXX,DGXXX1,DGXXX2,DGXXX3,DGXXXD,DR,DIE("NO^"),DGSEG
QUIT
+1 ;
CO(DFN,SDDT,SDISHDL) ; -- ask check out questions
+1 NEW DFN1,SDCOQUIT,SDIS,SDOE,SDPMTDF
+2 SET SDOE=$$GETDISP^SDVSIT2(DFN,SDDT)
if 'SDOE
GOTO COQ
+3 SET SDIS=$GET(^DPT(DFN,"DIS",9999999-SDDT,0))
+4 IF '$$SCE^DGSDU(+SDOE,7,0)!($PIECE($GET(^TMP("SDEVT",$JOB,SDISHDL,3,"DIS",0,"BEFORE")),"^",13)'=$PIECE(SDIS,"^",13))
DO INT^SDCO6(SDOE,.SDCOQUIT)
+5 IF '$DATA(SDCOQUIT)
Begin DoDot:1
+6 SET SDPMTDF=$SELECT($PIECE(^DG(43,1,0),"^",32):1,$PIECE($GET(^DIC(37,+$PIECE(SDIS,"^",7),0)),"^")="SCHEDULE FUTURE APPOINTMENT":1,1:0)
+7 IF $$ASK^SDCO6(SDPMTDF)
DO EN^SDCO(SDOE,SDISHDL,1)
End DoDot:1
COQ QUIT
