- 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 Jan 18, 2025@03:50:52 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