DGPMV322 ;ALB/MIR - DELETE INCOMPLETE ASIH XFR ; JUL 15 90@8
;;5.3;Registration;;Aug 13, 1993
UNDO ;if timeout during creation of ASIH admit, back out movements and correct PTF
W !!,*7,*7,"Time-out during ASIH movement...now deleting transfer and admission"
S DGPMAI=$P(DGPMA,"^",14),DGPMAA=$S($D(^DGPM(+DGPMAI,0)):^(0),1:"")
S DGPMADMI=$S($D(^DGPM(+DGPMDA,0)):$P(^(0),"^",15),1:""),DA=DGPMDA,DIK="^DGPM(" D ^DIK S ^UTILITY("DGPM",$J,2,DGPMDA,"A")="" ;delete xfr
S DGPMPTF=$S($D(^DGPM(+DGPMADMI,0)):$P(^(0),"^",16),1:""),DA=DGPMADMI D ^DIK S ^UTILITY("DGPM",$J,1,DGPMADMI,"A")="" ;delete hospital admission
S DA=DGPMPTF,DIK="^DGPT(" D ^DIK ;delete PTF for hosp admission
I $P(DGPMA,"^",18)=13 D DEL^DGPMV331 ;delete NHCU or DOM discharge, fix PTF/admission record
K DGPMAA,DGPMADMI,DGPMAI,DGPMPTF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV322 817 printed Oct 16, 2024@18:50:56 Page 2
DGPMV322 ;ALB/MIR - DELETE INCOMPLETE ASIH XFR ; JUL 15 90@8
+1 ;;5.3;Registration;;Aug 13, 1993
UNDO ;if timeout during creation of ASIH admit, back out movements and correct PTF
+1 WRITE !!,*7,*7,"Time-out during ASIH movement...now deleting transfer and admission"
+2 SET DGPMAI=$PIECE(DGPMA,"^",14)
SET DGPMAA=$SELECT($DATA(^DGPM(+DGPMAI,0)):^(0),1:"")
+3 ;delete xfr
SET DGPMADMI=$SELECT($DATA(^DGPM(+DGPMDA,0)):$PIECE(^(0),"^",15),1:"")
SET DA=DGPMDA
SET DIK="^DGPM("
DO ^DIK
SET ^UTILITY("DGPM",$JOB,2,DGPMDA,"A")=""
+4 ;delete hospital admission
SET DGPMPTF=$SELECT($DATA(^DGPM(+DGPMADMI,0)):$PIECE(^(0),"^",16),1:"")
SET DA=DGPMADMI
DO ^DIK
SET ^UTILITY("DGPM",$JOB,1,DGPMADMI,"A")=""
+5 ;delete PTF for hosp admission
SET DA=DGPMPTF
SET DIK="^DGPT("
DO ^DIK
+6 ;delete NHCU or DOM discharge, fix PTF/admission record
IF $PIECE(DGPMA,"^",18)=13
DO DEL^DGPMV331
+7 KILL DGPMAA,DGPMADMI,DGPMAI,DGPMPTF
QUIT
