DGPMV32 ;ALB/MIR - CONTINUE TRANSFER A PATIENT OPTION ;5/7/91 09:08
;;5.3;Registration;**418**;Aug 13, 1993
S DGPMTYP=$P(DGPMA,"^",18) I $S('DGPMTYP:1,'$D(^DG(405.2,+DGPMTYP,"E")):1,'^("E"):1,1:0) I '$P(DGPMA,"^",4)!'$P(DGPMA,"^",6) S DA=DGPMDA,DIK="^DGPM(" D ^DIK W !,"Incomplete Transfer...Deleted" K DIK S DGPMA="" G Q
I $S($P(DGPMA,"^",6,7)=$P(DGPMP,"^",6,7):0,'DGPMABL:0,1:1) S DGPMND=DGPMA D AB ;if change in room-bed or ward and next movement is to absence, update subsequent absences
CONT S DGPMTYP="^"_DGPMTYP_"^" I "^13^44^"[DGPMTYP D ECA^DGPMV321 ;Edit Corresponding admission when TO ASIH or RESUME ASIH
I DGPMTYP="^43^" D ASIHOF
I "^14^45^"[DGPMTYP D UHD^DGPMV321 ;if FROM ASIH or CHANGE ASIH LOCATION (O.F.)
I $D(^DG(405.1,+$P(DGPMA,"^",4),0)),'$P(^(0),"^",5) G Q
S Y=DGPMDA D:'DGPMOUT SPEC^DGPMV36
Q I DGPMA'=DGPMP W !,"Patient Transfer",$S('$D(^DGPM(+DGPMDA,0)):" Deleted.",'DGPMP:"red.",1:" Updated.") K ORQUIT
Q
AB ;update absences upon ward/room-bed change during admit or transfer patient options
S DGI=$P(DGPMND,"^"),DIE="^DGPM(",DIC(0)="M" W !,"Updating subsequent Absences"
F DGI=DGI:0 S DGI=$O(^DGPM("APTT2",DFN,DGI)) Q:'DGI F DGJ=0:0 S DGJ=$O(^DGPM("APTT2",DFN,DGI,DGJ)) Q:'DGJ I $D(^DGPM(DGJ,0)) S DGJJ=^(0) Q:$P(DGJJ,"^",14)'=DGPMCA D ABB
K DA,DGI,DGJ,DGJJ,DGPMND,DIC,DIE,J
Q
ABB ;absence checks
I $S($P(DGJJ,"^",18)=23:0,'$D(^DG(405.2,+$P(DGJJ,"^",18),"E")):1,^("E"):0,1:1) Q ;quit if from pass or not absence mvt
S J=$S("^1^23^43^45^"[("^"_$P(DGJJ,"^",18)_"^"):1,1:0),DA=+DGJ,DR=".06////"_$P(DGPMND,"^",6)_$S(J:";.07////"_$P(DGPMND,"^",7),1:"") K DQ,DG
S ^UTILITY("DGPM",$J,$P(DGJJ,"^",2),DA,"P")=DGJJ D ^DIE S ^UTILITY("DGPM",$J,$P(DGJJ,"^",2),DA,"A")=^DGPM(DA,0)
Q
DICS S DGX=$P(DGPM0,"^",4) I $S('$D(^DG(405.1,+DGX,0)):0,'$D(^DG(405.1,+Y,"F",+DGX)):1,1:0) S DGER=1 Q
S DGX=$P(DGPM2,"^",4) I $S('$D(^DG(405.1,+DGX,0)):0,'$D(^DG(405.1,+DGX,"F",+Y)):1,1:0) S DGER=1 Q
S DGX=$P(^DG(405.1,+Y,0),"^",3) I $P(DGPM0,"^",2)=1,$S('$D(^DG(405.2,+DGX,"E")):0,$P(^("E"),"^",2):0,1:1) S DGER=1 Q
I $P(DGPM0,"^",15),(DGX=14),($P(DGPM0,"^",18)'=45) S DGER=1 Q
I "^1^2^3^"[("^"_$P(^DGPM(DA,0),"^",18)_"^"),(DGX=4) S DGER=1 Q
;I "^13^43^44^45"[("^"_DGX_"^"),("^NH^D^"'[("^"_$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:"")_"^")) S DGER=1 Q
I "^13^43^44^45^"[("^"_DGX_"^"),("^NH^D^"'[("^"_$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:"")_"^"))&($P(^(0),"^",17)'=1) S DGER=1 Q ;p-418
;I DGX=14,("^NH^D^"'[("^"_$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:"")_"^")) S DGER=1 Q
I DGX=14,("^NH^D^"'[("^"_$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:"")_"^"))&($P(^(0),"^",17)'=1) S DGER=1 Q ;p-418
I $P(DGPMP,"^",15),(DGX'=$P(DGPMP,"^",18)) S DGER=1 Q
I DGX=44,($P(DGPM2,"^",18)=14) S DGER=1 Q
S DGER=0 Q
ASIHOF ;if TO ASIH (OTHER FACILITY) update pseudo discharge
I DGPMN S DGPMTN=DGPMA,DGPMNI=DGPMCA D FINDLAST,ASIHOF^DGPMV321 Q
S X1=+DGPMA,X2=30 D C^%DTC S DA=$P(DGPMAN,"^",17)
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)),DIE="^DGPM(",DR=".01///"_X K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0) ;update pseudo discharge
Q
SET ;set variables if coming from hospital admission (for FINDLAST)
S DGPMAB=0,DGPMTN=$S($D(^DGPM(+$P(DGPMAN,"^",21),0)):^(0),1:""),DGPMNI=$S($D(^DGPM(+$P(DGPMTN,"^",14),0)):+$P(DGPMTN,"^",14),1:"") Q:'DGPMNI
FINDLAST ;find the last transfer which originated ASIH care (either a TO ASIH or TO ASIH (OTHER FACILITY) transfer)
;
;input: DGPMNI - IFN of NHCU/DOM admission
; DGPMTN - 0 node of transfer which created hospital admission
;output: DGPMAB - the date/time on which ASIH care began. will be the
; same date/time for TO ASIH and TO ASIH (O.F.),
; earlier for RESUME ASIH IN PARENT FACILITY and
; CHANGE ASIH LOCATION (OTHER FACILITY) transfers.
;
S DGPMAB=0 I "^13^43^"[("^"_$P(DGPMTN,"^",18)_"^") S DGPMAB=+DGPMTN Q
I "^44^45^"[("^"_$P(DGPMTN,"^",18)_"^") F I=9999999.999999-+DGPMTN:0 S I=$O(^DGPM("APMV",DFN,DGPMNI,I)) Q:'I S X=$O(^(I,0)) I $D(^DGPM(+X,0)),("^13^43^"[("^"_$P(^(0),"^",18)_"^")) S DGPMAB=$P(^(0),"^",1) Q
K DGPMNI,DGPMTN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV32 4251 printed Dec 13, 2024@02:50:17 Page 2
DGPMV32 ;ALB/MIR - CONTINUE TRANSFER A PATIENT OPTION ;5/7/91 09:08
+1 ;;5.3;Registration;**418**;Aug 13, 1993
+2 SET DGPMTYP=$PIECE(DGPMA,"^",18)
IF $SELECT('DGPMTYP:1,'$DATA(^DG(405.2,+DGPMTYP,"E")):1,'^("E"):1,1:0)
IF '$PIECE(DGPMA,"^",4)!'$PIECE(DGPMA,"^",6)
SET DA=DGPMDA
SET DIK="^DGPM("
DO ^DIK
WRITE !,"Incomplete Transfer...Deleted"
KILL DIK
SET DGPMA=""
GOTO Q
+3 ;if change in room-bed or ward and next movement is to absence, update subsequent absences
IF $SELECT($PIECE(DGPMA,"^",6,7)=$PIECE(DGPMP,"^",6,7):0,'DGPMABL:0,1:1)
SET DGPMND=DGPMA
DO AB
CONT ;Edit Corresponding admission when TO ASIH or RESUME ASIH
SET DGPMTYP="^"_DGPMTYP_"^"
IF "^13^44^"[DGPMTYP
DO ECA^DGPMV321
+1 IF DGPMTYP="^43^"
DO ASIHOF
+2 ;if FROM ASIH or CHANGE ASIH LOCATION (O.F.)
IF "^14^45^"[DGPMTYP
DO UHD^DGPMV321
+3 IF $DATA(^DG(405.1,+$PIECE(DGPMA,"^",4),0))
IF '$PIECE(^(0),"^",5)
GOTO Q
+4 SET Y=DGPMDA
if 'DGPMOUT
DO SPEC^DGPMV36
Q IF DGPMA'=DGPMP
WRITE !,"Patient Transfer",$SELECT('$DATA(^DGPM(+DGPMDA,0)):" Deleted.",'DGPMP:"red.",1:" Updated.")
KILL ORQUIT
+1 QUIT
AB ;update absences upon ward/room-bed change during admit or transfer patient options
+1 SET DGI=$PIECE(DGPMND,"^")
SET DIE="^DGPM("
SET DIC(0)="M"
WRITE !,"Updating subsequent Absences"
+2 FOR DGI=DGI:0
SET DGI=$ORDER(^DGPM("APTT2",DFN,DGI))
if 'DGI
QUIT
FOR DGJ=0:0
SET DGJ=$ORDER(^DGPM("APTT2",DFN,DGI,DGJ))
if 'DGJ
QUIT
IF $DATA(^DGPM(DGJ,0))
SET DGJJ=^(0)
if $PIECE(DGJJ,"^",14)'=DGPMCA
QUIT
DO ABB
+3 KILL DA,DGI,DGJ,DGJJ,DGPMND,DIC,DIE,J
+4 QUIT
ABB ;absence checks
+1 ;quit if from pass or not absence mvt
IF $SELECT($PIECE(DGJJ,"^",18)=23:0,'$DATA(^DG(405.2,+$PIECE(DGJJ,"^",18),"E")):1,^("E"):0,1:1)
QUIT
+2 SET J=$SELECT("^1^23^43^45^"[("^"_$PIECE(DGJJ,"^",18)_"^"):1,1:0)
SET DA=+DGJ
SET DR=".06////"_$PIECE(DGPMND,"^",6)_$SELECT(J:";.07////"_$PIECE(DGPMND,"^",7),1:"")
KILL DQ,DG
+3 SET ^UTILITY("DGPM",$JOB,$PIECE(DGJJ,"^",2),DA,"P")=DGJJ
DO ^DIE
SET ^UTILITY("DGPM",$JOB,$PIECE(DGJJ,"^",2),DA,"A")=^DGPM(DA,0)
+4 QUIT
DICS SET DGX=$PIECE(DGPM0,"^",4)
IF $SELECT('$DATA(^DG(405.1,+DGX,0)):0,'$DATA(^DG(405.1,+Y,"F",+DGX)):1,1:0)
SET DGER=1
QUIT
+1 SET DGX=$PIECE(DGPM2,"^",4)
IF $SELECT('$DATA(^DG(405.1,+DGX,0)):0,'$DATA(^DG(405.1,+DGX,"F",+Y)):1,1:0)
SET DGER=1
QUIT
+2 SET DGX=$PIECE(^DG(405.1,+Y,0),"^",3)
IF $PIECE(DGPM0,"^",2)=1
IF $SELECT('$DATA(^DG(405.2,+DGX,"E")):0,$PIECE(^("E"),"^",2):0,1:1)
SET DGER=1
QUIT
+3 IF $PIECE(DGPM0,"^",15)
IF (DGX=14)
IF ($PIECE(DGPM0,"^",18)'=45)
SET DGER=1
QUIT
+4 IF "^1^2^3^"[("^"_$PIECE(^DGPM(DA,0),"^",18)_"^")
IF (DGX=4)
SET DGER=1
QUIT
+5 ;I "^13^43^44^45"[("^"_DGX_"^"),("^NH^D^"'[("^"_$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:"")_"^")) S DGER=1 Q
+6 ;p-418
IF "^13^43^44^45^"[("^"_DGX_"^")
IF ("^NH^D^"'[("^"_$SELECT($DATA(^DIC(42,+$PIECE(DGPMAN,"^",6),0)):$PIECE(^(0),"^",3),1:"")_"^"))&($PIECE(^(0),"^",17)'=1)
SET DGER=1
QUIT
+7 ;I DGX=14,("^NH^D^"'[("^"_$S($D(^DIC(42,+$P(DGPMAN,"^",6),0)):$P(^(0),"^",3),1:"")_"^")) S DGER=1 Q
+8 ;p-418
IF DGX=14
IF ("^NH^D^"'[("^"_$SELECT($DATA(^DIC(42,+$PIECE(DGPMAN,"^",6),0)):$PIECE(^(0),"^",3),1:"")_"^"))&($PIECE(^(0),"^",17)'=1)
SET DGER=1
QUIT
+9 IF $PIECE(DGPMP,"^",15)
IF (DGX'=$PIECE(DGPMP,"^",18))
SET DGER=1
QUIT
+10 IF DGX=44
IF ($PIECE(DGPM2,"^",18)=14)
SET DGER=1
QUIT
+11 SET DGER=0
QUIT
ASIHOF ;if TO ASIH (OTHER FACILITY) update pseudo discharge
+1 IF DGPMN
SET DGPMTN=DGPMA
SET DGPMNI=DGPMCA
DO FINDLAST
DO ASIHOF^DGPMV321
QUIT
+2 SET X1=+DGPMA
SET X2=30
DO C^%DTC
SET DA=$PIECE(DGPMAN,"^",17)
+3 ;update pseudo 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 DIE="^DGPM("
SET DR=".01///"_X
KILL DQ,DG
DO ^DIE
SET ^UTILITY("DGPM",$JOB,3,DA,"A")=^DGPM(DA,0)
+4 QUIT
SET ;set variables if coming from hospital admission (for FINDLAST)
+1 SET DGPMAB=0
SET DGPMTN=$SELECT($DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0)):^(0),1:"")
SET DGPMNI=$SELECT($DATA(^DGPM(+$PIECE(DGPMTN,"^",14),0)):+$PIECE(DGPMTN,"^",14),1:"")
if 'DGPMNI
QUIT
FINDLAST ;find the last transfer which originated ASIH care (either a TO ASIH or TO ASIH (OTHER FACILITY) transfer)
+1 ;
+2 ;input: DGPMNI - IFN of NHCU/DOM admission
+3 ; DGPMTN - 0 node of transfer which created hospital admission
+4 ;output: DGPMAB - the date/time on which ASIH care began. will be the
+5 ; same date/time for TO ASIH and TO ASIH (O.F.),
+6 ; earlier for RESUME ASIH IN PARENT FACILITY and
+7 ; CHANGE ASIH LOCATION (OTHER FACILITY) transfers.
+8 ;
+9 SET DGPMAB=0
IF "^13^43^"[("^"_$PIECE(DGPMTN,"^",18)_"^")
SET DGPMAB=+DGPMTN
QUIT
+10 IF "^44^45^"[("^"_$PIECE(DGPMTN,"^",18)_"^")
FOR I=9999999.999999-+DGPMTN:0
SET I=$ORDER(^DGPM("APMV",DFN,DGPMNI,I))
if 'I
QUIT
SET X=$ORDER(^(I,0))
IF $DATA(^DGPM(+X,0))
IF ("^13^43^"[("^"_$PIECE(^(0),"^",18)_"^"))
SET DGPMAB=$PIECE(^(0),"^",1)
QUIT
+11 KILL DGPMNI,DGPMTN
QUIT
