DGPMV322.m

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 ---DGPMV322   817     printed  Apr 09, 2024@22:02:53                                                                                                                                                                                                     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