DGPMV22 ;ALB/MIR - SCHEDULED ADMISSION? ; 23 NOV 90
;;5.3;Registration;**40**;Aug 13, 1993
SCHDADM ;is this a scheduled admission...DGPMSA=1 for yes, 0 for no
;must be within 7 days of actual scheduled admission entry
S X1=DGPMY,X2=-7 D C^%DTC S DGPMSD=$P(X,".")-.1
S X1=DGPMY,X2=7 D C^%DTC S DGPMED=$P(X,".")+.9
S DGCT=0 F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI S J=$S($D(^DGS(41.1,DGI,0)):^(0),1:"") I J,($P(J,"^",2)>DGPMSD),($P(J,"^",2)<DGPMED) I '$P(J,"^",13),'$P(J,"^",17) S DGCT=DGCT+1 D WR
I 'DGCT S DGPMSA=0 G SCHDQ
;
ASK W !,"Is this ",$S(DGCT=1:"the",1:"one of the")," scheduled admission",$S(DGCT>1:"s",1:"")," listed above" S %=1 D YN^DICN I %Y["?" W !?5,"Answer yes if this is a scheduled admission, otherwise no." G ASK
S DGPMSA=$S(%<0:0,1:'(%-1)) I 'DGPMSA G SCHDQ
I DGCT=1 S DGPMSA=^UTILITY("DGPMSA",$J,1) G SCHDQ
WHICH W !,"Which scheduled admission is it? " R X:DTIME I '$T S DGPMER="" D SCHDQ K DGPMY Q
I X["?" W !,"Choose a number 1-",DGCT G WHICH
W ! I X["^"!'X!(X<1)!(X>DGCT) G ASK
S DGPMSA=^UTILITY("DGPMSA",$J,X)
SCHDQ K X,X1,X2,DGCT,DGPMED,DGPMSD,^UTILITY("DGPMSA",$J),DGI,J Q
;
WR S Y=$P(J,"^",2) X ^DD("DD")
I DGCT=1 W !!,"Scheduled admissions:"
W !?2,DGCT,". ",Y,?25,$S($P(J,"^",10)="W":"WARD: "_$S($D(^DIC(42,+$P(J,"^",8),0)):$P(^(0),"^",1),1:""),$P(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$S($D(^DIC(45.7,+$P(J,"^",9),0)):$P(^(0),"^",1),1:""),1:"")
S ^UTILITY("DGPMSA",$J,DGCT)=DGI
Q
;
;
PTF(DFN,DGPMDA,DGPME,DGPMCA) ;ptf check
;
; prevent editing of a movement if related to admission w/closed PTF
; (either same admission or ASIH-related admission)
;
; Input: DFN = ien of patient file
; DGPMDA = ien of patient movement file
; DGPME = error flag if ptf closed out <by reference>
; DGPMCA = ien of admission movement from pt mvmnt file
;
; Output: DGPME = "" if no error; otherwise error message
;
I $S('+$G(DFN):1,'+$G(DGPMDA):1,'+$G(DGPMCA):1,1:0) Q
;
N MVTYPE,NODE,TRANS,X
S NODE=$G(^DGPM(DGPMDA,0)),TRANS=$P(NODE,U,2),TYPE=$P(NODE,U,18)
;
; check PTF of current admission for all movements
D PTFC($P(NODE,"^",14),.DGPME) I $G(DGPME)]"" G PTFQ
;
; check related nhcu/dom admission if current admission = TO ASIH
I TRANS=1 D:$P(NODE,"^",21) G PTFQ
. S X=$G(^DGPM($P(NODE,"^",21),0))
. D PTFC($P(X,"^",14),.DGPME)
;
; check related ASIH admission if nhcu/dom transfer movement
I TRANS=2 D G PTFQ
. I "^13^14^44^45^"'[("^"_TYPE_"^") Q ; not ASIH mvt...quit
. I "^13^44^"[("^"_TYPE_"^") D PTFC($P(NODE,"^",15),.DGPME) Q ; to asih or resume asih xfr...check hospital PTF & quit
. S X=$O(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-+NODE))),X=$O(^DGPM("APMV",DFN,DGPMCA,+X,0)) ; prior mvt ien
. S X=$G(^DGPM(+X,0)) ; prior mvt node
. I $P(X,"^",15) D PTFC($P(X,"^",15),.DGPME) ; if prior mvt associated with hospital admission, check hospital ptf
;
; check related nhcu/dom admission if asih discharge
I TRANS=3,("^41^46^"[("^"_TYPE_"^")) D
. S X=$G(^DGPM(+$P(NODE,"^",14),0)),X=$G(^DGPM(+$P(X,"^",21),0)) ; x=associated nhcu/dom transfer node
. I X]"" D PTFC($P(X,"^",14),.DGPME)
PTFQ Q
;
;
PTFC(ADMIT,DGPME) ;check if ptf in close out file/ set error flag if true
;
; Input: ADMIT = ien of admission record
; DGPME = ptf closed flag <by reference>
; Output: DGPME = set if ptf closed out
;
Q:'+$G(ADMIT)
N PTF
S PTF=$P($G(^DGPM(ADMIT,0)),"^",16)
I PTF,$D(^DGP(45.84,+PTF)) S DGPME="Associated PTF (#"_PTF_") is not open. Cannot edit this movement."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV22 3585 printed Nov 22, 2024@18:00:12 Page 2
DGPMV22 ;ALB/MIR - SCHEDULED ADMISSION? ; 23 NOV 90
+1 ;;5.3;Registration;**40**;Aug 13, 1993
SCHDADM ;is this a scheduled admission...DGPMSA=1 for yes, 0 for no
+1 ;must be within 7 days of actual scheduled admission entry
+2 SET X1=DGPMY
SET X2=-7
DO C^%DTC
SET DGPMSD=$PIECE(X,".")-.1
+3 SET X1=DGPMY
SET X2=7
DO C^%DTC
SET DGPMED=$PIECE(X,".")+.9
+4 SET DGCT=0
FOR DGI=0:0
SET DGI=$ORDER(^DGS(41.1,"B",DFN,DGI))
if 'DGI
QUIT
SET J=$SELECT($DATA(^DGS(41.1,DGI,0)):^(0),1:"")
IF J
IF ($PIECE(J,"^",2)>DGPMSD)
IF ($PIECE(J,"^",2)<DGPMED)
IF '$PIECE(J,"^",13)
IF '$PIECE(J,"^",17)
SET DGCT=DGCT+1
DO WR
+5 IF 'DGCT
SET DGPMSA=0
GOTO SCHDQ
+6 ;
ASK WRITE !,"Is this ",$SELECT(DGCT=1:"the",1:"one of the")," scheduled admission",$SELECT(DGCT>1:"s",1:"")," listed above"
SET %=1
DO YN^DICN
IF %Y["?"
WRITE !?5,"Answer yes if this is a scheduled admission, otherwise no."
GOTO ASK
+1 SET DGPMSA=$SELECT(%<0:0,1:'(%-1))
IF 'DGPMSA
GOTO SCHDQ
+2 IF DGCT=1
SET DGPMSA=^UTILITY("DGPMSA",$JOB,1)
GOTO SCHDQ
WHICH WRITE !,"Which scheduled admission is it? "
READ X:DTIME
IF '$TEST
SET DGPMER=""
DO SCHDQ
KILL DGPMY
QUIT
+1 IF X["?"
WRITE !,"Choose a number 1-",DGCT
GOTO WHICH
+2 WRITE !
IF X["^"!'X!(X<1)!(X>DGCT)
GOTO ASK
+3 SET DGPMSA=^UTILITY("DGPMSA",$JOB,X)
SCHDQ KILL X,X1,X2,DGCT,DGPMED,DGPMSD,^UTILITY("DGPMSA",$JOB),DGI,J
QUIT
+1 ;
WR SET Y=$PIECE(J,"^",2)
XECUTE ^DD("DD")
+1 IF DGCT=1
WRITE !!,"Scheduled admissions:"
+2 WRITE !?2,DGCT,". ",Y,?25,$SELECT($PIECE(J,"^",10)="W":"WARD: "_$SELECT($DATA(^DIC(42,+$PIECE(J,"^",8),0)):$PIECE(^(0),"^",1),1:""),$PIECE(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$SELECT($DATA(^DIC(45.7,+...
... $PIECE(J,"^",9),0)):$PIECE(^(0),"^",1),1:""),1:"")
+3 SET ^UTILITY("DGPMSA",$JOB,DGCT)=DGI
+4 QUIT
+5 ;
+6 ;
PTF(DFN,DGPMDA,DGPME,DGPMCA) ;ptf check
+1 ;
+2 ; prevent editing of a movement if related to admission w/closed PTF
+3 ; (either same admission or ASIH-related admission)
+4 ;
+5 ; Input: DFN = ien of patient file
+6 ; DGPMDA = ien of patient movement file
+7 ; DGPME = error flag if ptf closed out <by reference>
+8 ; DGPMCA = ien of admission movement from pt mvmnt file
+9 ;
+10 ; Output: DGPME = "" if no error; otherwise error message
+11 ;
+12 IF $SELECT('+$GET(DFN):1,'+$GET(DGPMDA):1,'+$GET(DGPMCA):1,1:0)
QUIT
+13 ;
+14 NEW MVTYPE,NODE,TRANS,X
+15 SET NODE=$GET(^DGPM(DGPMDA,0))
SET TRANS=$PIECE(NODE,U,2)
SET TYPE=$PIECE(NODE,U,18)
+16 ;
+17 ; check PTF of current admission for all movements
+18 DO PTFC($PIECE(NODE,"^",14),.DGPME)
IF $GET(DGPME)]""
GOTO PTFQ
+19 ;
+20 ; check related nhcu/dom admission if current admission = TO ASIH
+21 IF TRANS=1
if $PIECE(NODE,"^",21)
Begin DoDot:1
+22 SET X=$GET(^DGPM($PIECE(NODE,"^",21),0))
+23 DO PTFC($PIECE(X,"^",14),.DGPME)
End DoDot:1
GOTO PTFQ
+24 ;
+25 ; check related ASIH admission if nhcu/dom transfer movement
+26 IF TRANS=2
Begin DoDot:1
+27 ; not ASIH mvt...quit
IF "^13^14^44^45^"'[("^"_TYPE_"^")
QUIT
+28 ; to asih or resume asih xfr...check hospital PTF & quit
IF "^13^44^"[("^"_TYPE_"^")
DO PTFC($PIECE(NODE,"^",15),.DGPME)
QUIT
+29 ; prior mvt ien
SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-+NODE)))
SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,+X,0))
+30 ; prior mvt node
SET X=$GET(^DGPM(+X,0))
+31 ; if prior mvt associated with hospital admission, check hospital ptf
IF $PIECE(X,"^",15)
DO PTFC($PIECE(X,"^",15),.DGPME)
End DoDot:1
GOTO PTFQ
+32 ;
+33 ; check related nhcu/dom admission if asih discharge
+34 IF TRANS=3
IF ("^41^46^"[("^"_TYPE_"^"))
Begin DoDot:1
+35 ; x=associated nhcu/dom transfer node
SET X=$GET(^DGPM(+$PIECE(NODE,"^",14),0))
SET X=$GET(^DGPM(+$PIECE(X,"^",21),0))
+36 IF X]""
DO PTFC($PIECE(X,"^",14),.DGPME)
End DoDot:1
PTFQ QUIT
+1 ;
+2 ;
PTFC(ADMIT,DGPME) ;check if ptf in close out file/ set error flag if true
+1 ;
+2 ; Input: ADMIT = ien of admission record
+3 ; DGPME = ptf closed flag <by reference>
+4 ; Output: DGPME = set if ptf closed out
+5 ;
+6 if '+$GET(ADMIT)
QUIT
+7 NEW PTF
+8 SET PTF=$PIECE($GET(^DGPM(ADMIT,0)),"^",16)
+9 IF PTF
IF $DATA(^DGP(45.84,+PTF))
SET DGPME="Associated PTF (#"_PTF_") is not open. Cannot edit this movement."
+10 QUIT
