DGPMV31 ;ALB/MIR - CONTINUE ADMIT PROCESS ; 12 SEP 89 @12
;;5.3;Registration;**43,114,418**;Aug 13, 1993
I '$P(DGPMA,"^",6)!(DGPMN&DGPMOUT) D KILL G DQ
S Y=DGPMDA_"^1" I 'DGPMOUT S:DGPMN DIE("NO^")="" D SPEC^DGPMV36 I '$D(^DGPM("APHY",DGPMDA)) D KILL G DQ
I $D(DGPMSVC) S DGPMDER=0 ;FOR DISPO^DGPMV - from disposition
I DGPMN,$D(^DGS(41.1,+DGPMSA,0)) S DA=DGPMSA,DR="17////"_DGPMDA,DIE="^DGS(41.1," D ^DIE
I DGPMN D ^DGPMVBUL,CK^DGBLRV
I 'DGPMN,($P(DGPMP,"^",6,7)'=$P(DGPMA,"^",6,7)),DGPMABL S DGPMND=DGPMA D AB^DGPMV32
D SA
UP I $P(DGPMA,"^",21)&$S(+DGPMA'=+DGPMP:1,$P(DGPMA,"^",6,7)'=$P(DGPMP,"^",6,7):1,1:0) D ASIH
G:'$P(DGPMA,"^",6) PTF S X=$O(^DGWAIT("C",DFN,0)),Y=$O(^(+X,0)) G PTF:('X!'Y)
W !!,"This patient has the following waiting list entries on file:"
F I=0:0 S I=$O(^DGWAIT("C",DFN,I)) Q:'I D
. F J=0:0 S J=$O(^DGWAIT("C",DFN,I,J)) Q:'J D
. . S X=$G(^DGWAIT(I,"P",J,0)) I X']"" Q
. . W !?5,"TO: ",$S($D(^DG(40.8,+^DGWAIT(I,0),0)):$E($P(^(0),"^",1),1,20),1:"")
. . W ?32,"APPLIED: ",$$FMTE^XLFDT($P(X,"^",2)),?63,"BEDSECTION: ",$P(X,"^",5)
W !!,"Please delete from the waiting list if necessary.",!
PTF S PTF=$P(DGPMA,"^",16)
N DGELA
S DGELA=+$P($G(^DGPT(+PTF,101)),U,8)
S DR="",DIE="^DGPT(" S:$S('$D(^DGPT(+PTF,0)):0,$P(^(0),"^",2)'=+DGPMA:1,1:0) DR=DR_"2////"_+DGPMA_";" S DR=DR_"20;20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)",DA=PTF I $D(^DGPT(+DA,0)) K DQ,DG D ^DIE G DQ
;
G DQ:'DGPMN S Y=+DGPMA D CREATE^DGPTFCR
S PTF=Y
S DIE="^DGPM(",DA=DGPMDA,DR=".16////"_+Y K DQ,DG D ^DIE
;
;-- update admitting elig
S DR="",DIE="^DGPT("
S DR=DR_"20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)",DA=PTF
D ^DIE
;
D ADM^DGPMVODS
DQ I DGPMA'=DGPMP W !,"Patient Admi",$S($P(DGPMP,"^",4)']"":"tted",1:"ssion Updated"),!
Q
DICS S DGER=0 I DGPMTYP=40 S DGER=1 Q ;no TO ASIH!
I $P(^DGPM(DA,0),"^",18)=40 S DGER=1 Q ;don't let them change from TO ASIH!
Q:DGPMTYP'=18
S DGX1=9999999.9999999-+^DGPM(DA,0)
F DGX=1:1:2 S DGX1=$O(^DGPM("ATID1",DFN,DGX1)) Q:'DGX1 S DGY=$O(^(DGX1,0)) I $D(^DGPM(+DGY,0)) G:($P(^(0),"^",18)=40) DICSQ S DGY=$P(^(0),"^",6) I $D(^DIC(42,+DGY,0)),("^NH^D^"[("^"_$P(^(0),"^",3)_"^"))!($P(^(0),"^",17)=1) G DICSQ ;p-418
S DGER=1 Q
DICSQ S DGER=0 Q
ASIH ;update corresponding transfer and NHCU/DOM discharge episodes
W !,"Updating corresponding NHCU/DOM movements"
S DIE="^DGPM(",DA=$P(DGPMA,"^",21),DR=".01///"_+DGPMA_";.06////"_$P(DGPMA,"^",6)_";.07////"_$P(DGPMA,"^",7)
I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,2,DA,"P")=$S($D(^UTILITY("DGPM",$J,2,DA,"P")):^("P"),1:^DGPM(DA,0)) K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0)
Q:+DGPMP=+DGPMA S DGX=$S($D(^DGPM(+$P(DGPMA,"^",21),0)):^(0),1:0),DGX2=$S('$D(^DGPM(+$P(DGX,"^",14),0)):0,$D(^DGPM(+$P(^(0),"^",17),0)):+^(0),1:0),X1=+DGPMP,X2=30 Q:'X1!'DGX2 D C^%DTC Q:X'=+DGX2
K DGX2 S X1=+DGPMA,X2=30 D C^%DTC S DA=$S($D(^DGPM(+$P(DGX,"^",14),0)):$P(^(0),"^",17),1:"")
S DIE="^DGPM(",DR=".01///"_X I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)) K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0)
Q
KILL S DIK="^DGPM(",DA=DGPMDA W !,"Incomplete admission...Deleted" D ^DIK K DIK S DGPMA="" Q
;
SA Q:'$D(^DGS(41.1,"B",DFN)) S DGCT=0
F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI S J=$S($D(^DGS(41.1,DGI,0)):^(0),1:0),Y=$P(J,"^",2) I Y X ^DD("DD") I '$P(J,"^",13),'$P(J,"^",17) S DGCT=DGCT+1 D WR
K DGCT,DGI,J,Y Q
;
WR I DGCT=1 W !,"This patient has the following scheduled admissions on file:"
W !?5,Y,?25,$S($P(J,"^",10)="W":"WARD: "_$S($D(^DIC(42,+$P(J,"^",8),0)):$P(^(0),"^",1),1:""),$P(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$S($D(^DIC(45.7,+$P(J,"^",9),0)):$P(^(0),"^",1),1:""),1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV31 3747 printed Sep 23, 2025@20:26:08 Page 2
DGPMV31 ;ALB/MIR - CONTINUE ADMIT PROCESS ; 12 SEP 89 @12
+1 ;;5.3;Registration;**43,114,418**;Aug 13, 1993
+2 IF '$PIECE(DGPMA,"^",6)!(DGPMN&DGPMOUT)
DO KILL
GOTO DQ
+3 SET Y=DGPMDA_"^1"
IF 'DGPMOUT
if DGPMN
SET DIE("NO^")=""
DO SPEC^DGPMV36
IF '$DATA(^DGPM("APHY",DGPMDA))
DO KILL
GOTO DQ
+4 ;FOR DISPO^DGPMV - from disposition
IF $DATA(DGPMSVC)
SET DGPMDER=0
+5 IF DGPMN
IF $DATA(^DGS(41.1,+DGPMSA,0))
SET DA=DGPMSA
SET DR="17////"_DGPMDA
SET DIE="^DGS(41.1,"
DO ^DIE
+6 IF DGPMN
DO ^DGPMVBUL
DO CK^DGBLRV
+7 IF 'DGPMN
IF ($PIECE(DGPMP,"^",6,7)'=$PIECE(DGPMA,"^",6,7))
IF DGPMABL
SET DGPMND=DGPMA
DO AB^DGPMV32
+8 DO SA
UP IF $PIECE(DGPMA,"^",21)&$SELECT(+DGPMA'=+DGPMP:1,$PIECE(DGPMA,"^",6,7)'=$PIECE(DGPMP,"^",6,7):1,1:0)
DO ASIH
+1 if '$PIECE(DGPMA,"^",6)
GOTO PTF
SET X=$ORDER(^DGWAIT("C",DFN,0))
SET Y=$ORDER(^(+X,0))
if ('X!'Y)
GOTO PTF
+2 WRITE !!,"This patient has the following waiting list entries on file:"
+3 FOR I=0:0
SET I=$ORDER(^DGWAIT("C",DFN,I))
if 'I
QUIT
Begin DoDot:1
+4 FOR J=0:0
SET J=$ORDER(^DGWAIT("C",DFN,I,J))
if 'J
QUIT
Begin DoDot:2
+5 SET X=$GET(^DGWAIT(I,"P",J,0))
IF X']""
QUIT
+6 WRITE !?5,"TO: ",$SELECT($DATA(^DG(40.8,+^DGWAIT(I,0),0)):$EXTRACT($PIECE(^(0),"^",1),1,20),1:"")
+7 WRITE ?32,"APPLIED: ",$$FMTE^XLFDT($PIECE(X,"^",2)),?63,"BEDSECTION: ",$PIECE(X,"^",5)
End DoDot:2
End DoDot:1
+8 WRITE !!,"Please delete from the waiting list if necessary.",!
PTF SET PTF=$PIECE(DGPMA,"^",16)
+1 NEW DGELA
+2 SET DGELA=+$PIECE($GET(^DGPT(+PTF,101)),U,8)
+3 SET DR=""
SET DIE="^DGPT("
if $SELECT('$DATA(^DGPT(+PTF,0))
SET DR=DR_"2////"_+DGPMA_";"
SET DR=DR_"20;20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)"
SET DA=PTF
IF $DATA(^DGPT(+DA,0))
KILL DQ,DG
DO ^DIE
GOTO DQ
+4 ;
+5 if 'DGPMN
GOTO DQ
SET Y=+DGPMA
DO CREATE^DGPTFCR
+6 SET PTF=Y
+7 SET DIE="^DGPM("
SET DA=DGPMDA
SET DR=".16////"_+Y
KILL DQ,DG
DO ^DIE
+8 ;
+9 ;-- update admitting elig
+10 SET DR=""
SET DIE="^DGPT("
+11 SET DR=DR_"20.1////^S X=$$ELIG^DGUTL3(DFN,2,DGELA)"
SET DA=PTF
+12 DO ^DIE
+13 ;
+14 DO ADM^DGPMVODS
DQ IF DGPMA'=DGPMP
WRITE !,"Patient Admi",$SELECT($PIECE(DGPMP,"^",4)']"":"tted",1:"ssion Updated"),!
+1 QUIT
DICS ;no TO ASIH!
SET DGER=0
IF DGPMTYP=40
SET DGER=1
QUIT
+1 ;don't let them change from TO ASIH!
IF $PIECE(^DGPM(DA,0),"^",18)=40
SET DGER=1
QUIT
+2 if DGPMTYP'=18
QUIT
+3 SET DGX1=9999999.9999999-+^DGPM(DA,0)
+4 ;p-418
FOR DGX=1:1:2
SET DGX1=$ORDER(^DGPM("ATID1",DFN,DGX1))
if 'DGX1
QUIT
SET DGY=$ORDER(^(DGX1,0))
IF $DATA(^DGPM(+DGY,0))
if ($PIECE(^(0),"^",18)=40)
GOTO DICSQ
SET DGY=$PIECE(^(0),"^",6)
IF $DATA(^DIC(42,+DGY,0))
IF ("^NH^D^"[("^"_$PIECE(^(0),"^",3)_"^"))!($PIECE(^(0),"^",17)=1)
GOTO DICSQ
+5 SET DGER=1
QUIT
DICSQ SET DGER=0
QUIT
ASIH ;update corresponding transfer and NHCU/DOM discharge episodes
+1 WRITE !,"Updating corresponding NHCU/DOM movements"
+2 SET DIE="^DGPM("
SET DA=$PIECE(DGPMA,"^",21)
SET DR=".01///"_+DGPMA_";.06////"_$PIECE(DGPMA,"^",6)_";.07////"_$PIECE(DGPMA,"^",7)
+3 IF $DATA(^DGPM(+DA,0))
SET ^UTILITY("DGPM",$JOB,2,DA,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,2,DA,"P")):^("P"),1:^DGPM(DA,0))
KILL DQ,DG
DO ^DIE
SET ^UTILITY("DGPM",$JOB,2,DA,"A")=^DGPM(DA,0)
+4 if +DGPMP=+DGPMA
QUIT
SET DGX=$SELECT($DATA(^DGPM(+$PIECE(DGPMA,"^",21),0)):^(0),1:0)
SET DGX2=$SELECT('$DATA(^DGPM(+$PIECE(DGX,"^",14),0)):0,$DATA(^DGPM(+$PIECE(^(0),"^",17),0)):+^(0),1:0)
SET X1=+DGPMP
SET X2=30
if 'X1!'DGX2
QUIT
DO C^%DTC
if X'=+DGX2
QUIT
+5 KILL DGX2
SET X1=+DGPMA
SET X2=30
DO C^%DTC
SET DA=$SELECT($DATA(^DGPM(+$PIECE(DGX,"^",14),0)):$PIECE(^(0),"^",17),1:"")
+6 SET DIE="^DGPM("
SET DR=".01///"_X
IF $DATA(^DGPM(+DA,0))
SET ^UTILITY("DGPM",$JOB,3,DA,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,3,DA,"P")):^("P"),1:^DGPM(DA,0))
KILL DQ,DG
DO ^DIE
SET ^UTILITY("DGPM",$JOB,3,DA,"A")=^DGPM(DA,0)
+7 QUIT
KILL SET DIK="^DGPM("
SET DA=DGPMDA
WRITE !,"Incomplete admission...Deleted"
DO ^DIK
KILL DIK
SET DGPMA=""
QUIT
+1 ;
SA if '$DATA(^DGS(41.1,"B",DFN))
QUIT
SET DGCT=0
+1 FOR DGI=0:0
SET DGI=$ORDER(^DGS(41.1,"B",DFN,DGI))
if 'DGI
QUIT
SET J=$SELECT($DATA(^DGS(41.1,DGI,0)):^(0),1:0)
SET Y=$PIECE(J,"^",2)
IF Y
XECUTE ^DD("DD")
IF '$PIECE(J,"^",13)
IF '$PIECE(J,"^",17)
SET DGCT=DGCT+1
DO WR
+2 KILL DGCT,DGI,J,Y
QUIT
+3 ;
WR IF DGCT=1
WRITE !,"This patient has the following scheduled admissions on file:"
+1 WRITE !?5,Y,?25,$SELECT($PIECE(J,"^",10)="W":"WARD: "_$SELECT($DATA(^DIC(42,+$PIECE(J,"^",8),0)):$PIECE(^(0),"^",1),1:""),$PIECE(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$SELECT($DATA(^DIC(45.7,+$PIECE(J,"^",9),0)):$PIECE(^(0),"^",1),1:"")
,1:"")
+2 QUIT
