- 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 Feb 19, 2025@00:16:19 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