DGPMV331 ;ALB/MIR - ASIH DISCHARGE PROCESSING ; 11 JAN 89 @9
;;5.3;Registration;;Aug 13, 1993
ASIH ;if admission type was TO ASIH...
Q:'$D(^DGPM(+$P(DGPMAN,"^",21),0)) S DGPMAI=$P(^(0),"^",14),DGPMAA=$S($D(^DGPM(+DGPMAI,0)):^(0),1:"")
D DEL:($P(DGPMA,"^",18)=41),CRXFR:($P(DGPMA,"^",18)=46) G Q:("^41^46^"[("^"_$P(DGPMA,"^",18)_"^"))
Q:+DGPMP=+DGPMA
S DA=$S($D(^DGPM(+$P(DGPMAA,"^",17),0)):$P(DGPMAA,"^",17),1:"") I $D(^DGPM(+DA,0)),($P(^(0),"^",18)=47) G Q
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)),DR=".01///"_+DGPMA_";.22////"_2,DIE="^DGPM(" K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0) ;update NHCU/DOM discharge
S DIE="^DGPM(",DA=DGPMDA,DR=".22////"_1 K DQ,DG D ^DIE
S DA=$P(DGPMAA,"^",16) I $D(^DGPT(+DA,0)) S DIE="^DGPT(",DR="70////"_+DGPMA K DQ,DG D ^DIE ;update NHCU/DOM PTF discharge date
Q K DGPMAA,DGPMAI,DGPMXMT Q
DEL ;delete the NHCU discharge if FROM ASIH - called from transfer, too
S DA=$S($D(^DGPM(+$P(DGPMAA,"^",17),0)):$P(DGPMAA,"^",17),1:"")
I $D(^DGPM(+DA,0)) D
. S ^UTILITY("DGPM",$J,1,DGPMAI,"P")=DGPMAA
. S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)),^("A")="",DIK="^DGPM(" D ^DIK ;Delete ASIH discharge
. S ^UTILITY("DGPM",$J,1,DGPMAI,"A")=$G(^DGPM(DGPMAI,0))
S DA=$S($D(^DGPT(+$P(DGPMAA,"^",16),0)):$P(DGPMAA,"^",16),1:"") I DA S DR="70///@;71///@;72///@",DIE="^DGPT(" K DQ,DG D ^DIE:DR]""
Q:DGPMT=2 ;quit if coming from xfr routine (returning from ASIH (O.F.)
CRXFR ;for FROM ASIH and CONTINUED ASIH (O.F.), create corresponding transfer
S DGMAS=$S($P(DGPMA,"^",18)=41:14,1:45) D FAMT^DGPMV30 S (DGX,DGHX)=DGFAC K DGFAC ;get active mvt type for from asih or continued asih (of) transfer
S DIE="^DGPM(",DR=".22////"_1,DA=DGPMDA K DQ,DG D ^DIE ;set sequence number for hospital discharge
S DIE("NO^")="",X=+DGPMA,DGPM0ND=+DGPMA_"^"_2_"^"_DFN_"^"_DGX_"^^^^^^^^^^"_DGPMAI_"^^^^^^^^"_2 D NEW^DGPMV3
S ^UTILITY("DGPM",$J,2,+Y,"P")="",^UTILITY("DGPM",$J,2,+Y,"A")=$G(^DGPM(+Y,0))
S DGX=$S($P(DGPMA,"^",18)=41:14,1:45)
S DIE="^DGPM(",(DA,DGPMXMT)=+Y,DR=$S(DGX=45:".05",1:".06;.07"),DIE("NO^")="" I DGX=14 K DQ,DG D ^DIE G:'$P(^DGPM(DA,0),"^",6) UNDO S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0) D SPEC Q
S X=0 F I=+DGPMAN:0 S I=$O(^DGPM("APMV",DFN,DGPMAI,I)) Q:'I S J=$O(^(I,0)) I $D(^DGPM(+J,0)),("^13^43^"[("^"_$P(^(0),"^",18)_"^")) S X=^(0) Q
I X S I=$O(^DGPM("APMV",DFN,DGPMAI,I)),J=$O(^(+I,0)) I $D(^DGPM(+J,0)) S X=^(0),DR=DR_$S($P(X,"^",6):";.06////"_$P(X,"^",6),1:"")_$S($P(X,"^",7):";.07////"_$P(X,"^",7),1:"")
K DQ,DG D ^DIE I $P(^DGPM(DA,0),"^",5) S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0) D SPEC Q
UNDO ;delete discharge/transfer is time-out during transfer
S DGPMER=1 W !!,*7,*7,"Time-out during ASIH movement...now deleting discharge and transfer"
S DIK="^DGPM(" F DA=DGPMDA,DGPMXMT D ^DIK S ^UTILITY("DGPM",$J,$S(DA=DGPMDA:3,1:2),"A")=""
I $P(DGPMA,"^",18)=41 D SET^DGPMV32 Q:'$D(^DGPM(+$P(DGPMAN,"^",21),0)) N DGPMCA,DGPMAN S DGPMCA=$P(^(0),"^",14),DGPMAN=$S($D(^DGPM(DGPMCA,0)):^(0),1:"") D ASIHOF^DGPMV321
Q
SPEC ;ask specialty on return?
S Y=DGPMXMT I $D(^DG(405.1,+DGHX,0)),$P(^(0),"^",5) D SPEC^DGPMV36
K DGHX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV331 3247 printed Sep 23, 2025@20:26:13 Page 2
DGPMV331 ;ALB/MIR - ASIH DISCHARGE PROCESSING ; 11 JAN 89 @9
+1 ;;5.3;Registration;;Aug 13, 1993
ASIH ;if admission type was TO ASIH...
+1 if '$DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
QUIT
SET DGPMAI=$PIECE(^(0),"^",14)
SET DGPMAA=$SELECT($DATA(^DGPM(+DGPMAI,0)):^(0),1:"")
+2 if ($PIECE(DGPMA,"^",18)=41)
DO DEL
if ($PIECE(DGPMA,"^",18)=46)
DO CRXFR
if ("^41^46^"[("^"_$PIECE(DGPMA,"^",18)_"^"))
GOTO Q
+3 if +DGPMP=+DGPMA
QUIT
+4 SET DA=$SELECT($DATA(^DGPM(+$PIECE(DGPMAA,"^",17),0)):$PIECE(DGPMAA,"^",17),1:"")
IF $DATA(^DGPM(+DA,0))
IF ($PIECE(^(0),"^",18)=47)
GOTO Q
+5 ;update NHCU/DOM discharge
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))
SET DR=".01///"_+DGPMA_";.22////"_2
SET DIE="^DGPM("
KILL DQ,DG
DO ^DIE
SET ^UTILITY("DGPM",$JOB,3,DA,"A")=^DGPM(DA,0)
+6 SET DIE="^DGPM("
SET DA=DGPMDA
SET DR=".22////"_1
KILL DQ,DG
DO ^DIE
+7 ;update NHCU/DOM PTF discharge date
SET DA=$PIECE(DGPMAA,"^",16)
IF $DATA(^DGPT(+DA,0))
SET DIE="^DGPT("
SET DR="70////"_+DGPMA
KILL DQ,DG
DO ^DIE
Q KILL DGPMAA,DGPMAI,DGPMXMT
QUIT
DEL ;delete the NHCU discharge if FROM ASIH - called from transfer, too
+1 SET DA=$SELECT($DATA(^DGPM(+$PIECE(DGPMAA,"^",17),0)):$PIECE(DGPMAA,"^",17),1:"")
+2 IF $DATA(^DGPM(+DA,0))
Begin DoDot:1
+3 SET ^UTILITY("DGPM",$JOB,1,DGPMAI,"P")=DGPMAA
+4 ;Delete ASIH discharge
SET ^UTILITY("DGPM",$JOB,3,DA,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,3,DA,"P")):^("P"),1:^DGPM(DA,0))
SET ^("A")=""
SET DIK="^DGPM("
DO ^DIK
+5 SET ^UTILITY("DGPM",$JOB,1,DGPMAI,"A")=$GET(^DGPM(DGPMAI,0))
End DoDot:1
+6 SET DA=$SELECT($DATA(^DGPT(+$PIECE(DGPMAA,"^",16),0)):$PIECE(DGPMAA,"^",16),1:"")
IF DA
SET DR="70///@;71///@;72///@"
SET DIE="^DGPT("
KILL DQ,DG
if DR]""
DO ^DIE
+7 ;quit if coming from xfr routine (returning from ASIH (O.F.)
if DGPMT=2
QUIT
CRXFR ;for FROM ASIH and CONTINUED ASIH (O.F.), create corresponding transfer
+1 ;get active mvt type for from asih or continued asih (of) transfer
SET DGMAS=$SELECT($PIECE(DGPMA,"^",18)=41:14,1:45)
DO FAMT^DGPMV30
SET (DGX,DGHX)=DGFAC
KILL DGFAC
+2 ;set sequence number for hospital discharge
SET DIE="^DGPM("
SET DR=".22////"_1
SET DA=DGPMDA
KILL DQ,DG
DO ^DIE
+3 SET DIE("NO^")=""
SET X=+DGPMA
SET DGPM0ND=+DGPMA_"^"_2_"^"_DFN_"^"_DGX_"^^^^^^^^^^"_DGPMAI_"^^^^^^^^"_2
DO NEW^DGPMV3
+4 SET ^UTILITY("DGPM",$JOB,2,+Y,"P")=""
SET ^UTILITY("DGPM",$JOB,2,+Y,"A")=$GET(^DGPM(+Y,0))
+5 SET DGX=$SELECT($PIECE(DGPMA,"^",18)=41:14,1:45)
+6 SET DIE="^DGPM("
SET (DA,DGPMXMT)=+Y
SET DR=$SELECT(DGX=45:".05",1:".06;.07")
SET DIE("NO^")=""
IF DGX=14
KILL DQ,DG
DO ^DIE
if '$PIECE(^DGPM(DA,0),"^",6)
GOTO UNDO
SET ^UTILITY("DGPM",$JOB,2,DA,"A")=^DGPM(DA,0)
DO SPEC
QUIT
+7 SET X=0
FOR I=+DGPMAN:0
SET I=$ORDER(^DGPM("APMV",DFN,DGPMAI,I))
if 'I
QUIT
SET J=$ORDER(^(I,0))
IF $DATA(^DGPM(+J,0))
IF ("^13^43^"[("^"_$PIECE(^(0),"^",18)_"^"))
SET X=^(0)
QUIT
+8 IF X
SET I=$ORDER(^DGPM("APMV",DFN,DGPMAI,I))
SET J=$ORDER(^(+I,0))
IF $DATA(^DGPM(+J,0))
SET X=^(0)
SET DR=DR_$SELECT($PIECE(X,"^",6):";.06////"_$PIECE(X,"^",6),1:"")_$SELECT($PIECE(X,"^",7):";.07////"_$PIECE(X,"^",7),1:"")
+9 KILL DQ,DG
DO ^DIE
IF $PIECE(^DGPM(DA,0),"^",5)
SET ^UTILITY("DGPM",$JOB,2,DA,"A")=^DGPM(DA,0)
DO SPEC
QUIT
UNDO ;delete discharge/transfer is time-out during transfer
+1 SET DGPMER=1
WRITE !!,*7,*7,"Time-out during ASIH movement...now deleting discharge and transfer"
+2 SET DIK="^DGPM("
FOR DA=DGPMDA,DGPMXMT
DO ^DIK
SET ^UTILITY("DGPM",$JOB,$SELECT(DA=DGPMDA:3,1:2),"A")=""
+3 IF $PIECE(DGPMA,"^",18)=41
DO SET^DGPMV32
if '$DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
QUIT
NEW DGPMCA,DGPMAN
SET DGPMCA=$PIECE(^(0),"^",14)
SET DGPMAN=$SELECT($DATA(^DGPM(DGPMCA,0)):^(0),1:"")
DO ASIHOF^DGPMV321
+4 QUIT
SPEC ;ask specialty on return?
+1 SET Y=DGPMXMT
IF $DATA(^DG(405.1,+DGHX,0))
IF $PIECE(^(0),"^",5)
DO SPEC^DGPMV36
+2 KILL DGHX
+3 QUIT
