VADPT3.m

VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm

 ;;5.3;Registration;**532,749**;Aug 13, 1993;Build 10

 ;Inpatient variables [Version 5.0 and above]

6 ;

 S (NOW,VAX("DAT"))=$$NOW^XLFDT,NOWI=9999999.999999-NOW

 ;

 I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry

 ;

 I $D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") D LAST G GO:E,Q

 ;

 S VAX=$S($D(VAIP("D")):VAIP("D"),$D(VAINDT):VAINDT,1:0)

 I VAX S:VAX?7N!(VAX?7N1".".N) VAX("DT")=VAX I '$D(VAX("DT")) G Q ;Invalid Entry

 ;

 S:'$D(VAX("DT")) VAX("DT")=NOW

 I VAX("DT")=VAX("DAT") S E=$S($D(^DPT(DFN,.102)):+^(.102),1:0),E=$S($D(^DGPM(E,0)):E,1:0) G GO:E D LODGER G GO:E D ASIHOF G GO:E,Q ;Current IP

 ;

 ;Find Past Movement

 S VAX=+$O(^DGPM("APID",DFN,9999999.999999-VAX("DT"))) I 'VAX D LODGER G GO:E,Q

 S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I '$D(^DGPM(VAX,0)) D LODGER G GO:E,Q

 S VAZ=^DGPM(VAX,0) D OK G GO:E D LODGER G GO:E,Q

 ;

GO S:'$D(VAX("DT")) VAX("DT")=NOW D ^VADPT31 ; setting of VAX("DT") can be removed??

 ;

Q K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("VADPTZ",$J,DFN) D KVAR^VADPT30 Q

 ;

OK N VAADT,VADDT,VAQUIT

 S E=0,VAZ2="^"_(+$P(VAZ,"^",18))_"^"

 I "^13^41^46^"[VAZ2 D OK1 Q:'VAX  G OK

 I "^42^"[VAZ2 D 42 I 'Y D OK1 Q:'VAX  G OK

 I "^47^"[VAZ2 D 47 I 'Y D OK1 Q:'VAX  G OK

 I $D(VAX("DT")),$P(VAZ,"^",2)=3,VAZ'>VAX("DT") Q

 ;DG*5.3*532

 ;Check for out-of-order disch. recs caused by same day adm./disch.

 ;where disch. date < adm. date because disch. date had no time

 I +VAZ<2890000,$D(VAX("DT")),$P(VAZ,"^",2)'=3 S VAQUIT=0 D  Q:VAQUIT

 .S VAADT=$P(VAZ,"^",14) Q:'VAADT

 .S VADDT=$P($G(^DGPM(VAADT,0)),"^",17) Q:'VADDT

 .S VADDT=$P($G(^DGPM(VADDT,0)),"^",14) I $P(VADDT,".",2)="",VADDT=$P(VAADT,"."),VAZ'>VAX("DT") S VAQUIT=1

 S E=+VAX Q

 ;

OK1 S VAX=+$O(^DGPM("APID",DFN,9999999.9999999-(VAZ+($P(VAZ,"^",22)/10000000)))),VAX=+$O(^(VAX,0))

 I VAX,$D(^DGPM(VAX,0)) S VAZ=^(0)

 Q

 ;

LAST ; returns last movement for patient

 ; called by bed control and pt inquiry

 S VAX=+$O(^DGPM("APID",DFN,NOWI)),E=0

 I $D(VAIP("L")) D LLDCHK G LASTQ:E

 S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I $D(^DGPM(VAX,0)) S VAZ=^(0) D OK

LASTQ S VAX("DT")=NOW

 Q

 ;

LODGER ;

 S E=0 G LODGERQ:'$D(VAIP("L"))

 I VAX("DT")=VAX("DAT") S VAX=$S($D(^DPT(DFN,.107)):^(.107),1:"") G LODGERQ:VAX']"" S E=$S($D(^DPT("LD",VAX,DFN)):+^(DFN),1:0) G LODGERQ

 ;

 S VAX=$O(^DGPM("ATID4",DFN,9999999.999999-VAX("DT"))) S:VAX E=+$O(^DGPM("ATID4",DFN,VAX,0))

 I E S E=$S($D(^DGPM(E,0)):E,1:0) I E,$D(^DGPM(+$P(^(0),"^",17),0)),^(0)'>VAX("DT") S E=0

LODGERQ Q

 ;

LLDCHK ; -- last lodger mvt checking ; build array of inverse dates and chk

 N IDT S IDT(VAX)=0

 S IDT=+$O(^DGPM("ATID4",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))

 S IDT=+$O(^DGPM("ATID5",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))

 S IDT=+$O(IDT(0)) I IDT S E=IDT(IDT),E=$S($D(^DGPM(E,0)):E,1:0)

 Q

 ; 

CHK ;

 G VAR^VADPT30

 ;

ASIHOF ; -- is last mvt asih oth fac

 S E=0,VAX=$S('$O(^DGPM("APID",DFN,NOWI)):"",1:$O(^DGPM("APID",DFN,$O(^(NOWI)),0)))

 I VAX,$D(^DGPM(VAX,0)),"^43^45^"[("^"_$P(^(0),"^",18)_"^") S E=VAX

 Q

 ;

42 ; -- check to see if this mvt can be used; for 'while asih' d/c category

 ;   If Y returned high then mvt is good

 ;

 I VAZ'<VAX("DAT") S Y=0 G Q42 ; not a real d/c yet

 I $P(VAZ,"^",22)=2 S Y=0 G Q42 ; nhcu d/c assoicated w/asih d/c (seq #2)

 D SCAN

Q42 Q

 ;

SCAN ; -- determine is d/c while in other fac(Y=1 returned if so.)

 ;

 N VAID,VACA,M S Y=0,VAID=9999999.999999-VAZ,VACA=+$P(VAZ,"^",14)

 F VAID=VAID:0 S VAID=$O(^DGPM("APMV",DFN,VACA,VAID)) Q:'VAID  I $D(^DGPM(+$O(^(VAID,0)),0)) S M=$P(^(0),"^",18) I "^13^44^43^45^"[("^"_M_"^") S Y=$S(M=43!(M=45):1,1:0) Q

 Q

 ;

47 ; -- check to see if d/c from nhcu while asih in other fac

 ;   If y returned high then mvt is good.

 D SCAN Q

 ;

 ; 13 = to asih (vah)     (xfr)|44 = resume asih in parent facility (xfr)

 ; 41 = from asih         (d/c)|45 = change asih location(other fac)(xfr)

 ; 42 = while asih        (d/c)|46 = continues asih (other fac)     (d/c)

 ; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---VADPT3   4164     printed  Feb 19, 2025@00:27:16                                                                                                                                                                                                      Page 2

VADPT3    ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm

 +1       ;;5.3;Registration;**532,749**;Aug 13, 1993;Build 10

 +2       ;Inpatient variables [Version 5.0 and above]

6         ;

 +1        SET (NOW,VAX("DAT"))=$$NOW^XLFDT

           SET NOWI=9999999.999999-NOW

 +2       ;

 +3       ;Specific Entry

           IF $DATA(VAIP("E"))

               IF $DATA(^DGPM(+VAIP("E"),0))

                   SET VAX("DT")=+^(0)

                   SET E=+VAIP("E")

                   GOTO GO

 +4       ;

 +5        IF $DATA(VAIP("D"))

               IF "^l^L^"[("^"_$EXTRACT(VAIP("D"))_"^")

                   DO LAST

                   if E

                       GOTO GO

                   GOTO Q

 +6       ;

 +7        SET VAX=$SELECT($DATA(VAIP("D")):VAIP("D"),$DATA(VAINDT):VAINDT,1:0)

 +8       ;Invalid Entry

           IF VAX

               if VAX?7N!(VAX?7N1".".N)

                   SET VAX("DT")=VAX

               IF '$DATA(VAX("DT"))

                   GOTO Q

 +9       ;

 +10       if '$DATA(VAX("DT"))

               SET VAX("DT")=NOW

 +11      ;Current IP

           IF VAX("DT")=VAX("DAT")

               SET E=$SELECT($DATA(^DPT(DFN,.102)):+^(.102),1:0)

               SET E=$SELECT($DATA(^DGPM(E,0)):E,1:0)

               if E

                   GOTO GO

               DO LODGER

               if E

                   GOTO GO

               DO ASIHOF

               if E

                   GOTO GO

               GOTO Q

 +12      ;

 +13      ;Find Past Movement

 +14       SET VAX=+$ORDER(^DGPM("APID",DFN,9999999.999999-VAX("DT")))

           IF 'VAX

               DO LODGER

               if E

                   GOTO GO

               GOTO Q

 +15       SET VAX=+$ORDER(^DGPM("APID",DFN,VAX,0))

           IF '$DATA(^DGPM(VAX,0))

               DO LODGER

               if E

                   GOTO GO

               GOTO Q

 +16       SET VAZ=^DGPM(VAX,0)

           DO OK

           if E

               GOTO GO

           DO LODGER

           if E

               GOTO GO

           GOTO Q

 +17      ;

GO        ; setting of VAX("DT") can be removed??

           if '$DATA(VAX("DT"))

               SET VAX("DT")=NOW

           DO ^VADPT31

 +1       ;

Q          KILL NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("VADPTZ",$JOB,DFN)

           DO KVAR^VADPT30

           QUIT 

 +1       ;

OK         NEW VAADT,VADDT,VAQUIT

 +1        SET E=0

           SET VAZ2="^"_(+$PIECE(VAZ,"^",18))_"^"

 +2        IF "^13^41^46^"[VAZ2

               DO OK1

               if 'VAX

                   QUIT 

               GOTO OK

 +3        IF "^42^"[VAZ2

               DO 42

               IF 'Y

                   DO OK1

                   if 'VAX

                       QUIT 

                   GOTO OK

 +4        IF "^47^"[VAZ2

               DO 47

               IF 'Y

                   DO OK1

                   if 'VAX

                       QUIT 

                   GOTO OK

 +5        IF $DATA(VAX("DT"))

               IF $PIECE(VAZ,"^",2)=3

                   IF VAZ'>VAX("DT")

                       QUIT 

 +6       ;DG*5.3*532

 +7       ;Check for out-of-order disch. recs caused by same day adm./disch.

 +8       ;where disch. date < adm. date because disch. date had no time

 +9        IF +VAZ<2890000

               IF $DATA(VAX("DT"))

                   IF $PIECE(VAZ,"^",2)'=3

                       SET VAQUIT=0

                       Begin DoDot:1

 +10                       SET VAADT=$PIECE(VAZ,"^",14)

                           if 'VAADT

                               QUIT 

 +11                       SET VADDT=$PIECE($GET(^DGPM(VAADT,0)),"^",17)

                           if 'VADDT

                               QUIT 

 +12                       SET VADDT=$PIECE($GET(^DGPM(VADDT,0)),"^",14)

                           IF $PIECE(VADDT,".",2)=""

                               IF VADDT=$PIECE(VAADT,".")

                                   IF VAZ'>VAX("DT")

                                       SET VAQUIT=1

                       End DoDot:1

                       if VAQUIT

                           QUIT 

 +13       SET E=+VAX

           QUIT 

 +14      ;

OK1        SET VAX=+$ORDER(^DGPM("APID",DFN,9999999.9999999-(VAZ+($PIECE(VAZ,"^",22)/10000000))))

           SET VAX=+$ORDER(^(VAX,0))

 +1        IF VAX

               IF $DATA(^DGPM(VAX,0))

                   SET VAZ=^(0)

 +2        QUIT 

 +3       ;

LAST      ; returns last movement for patient

 +1       ; called by bed control and pt inquiry

 +2        SET VAX=+$ORDER(^DGPM("APID",DFN,NOWI))

           SET E=0

 +3        IF $DATA(VAIP("L"))

               DO LLDCHK

               if E

                   GOTO LASTQ

 +4        SET VAX=+$ORDER(^DGPM("APID",DFN,VAX,0))

           IF $DATA(^DGPM(VAX,0))

               SET VAZ=^(0)

               DO OK

LASTQ      SET VAX("DT")=NOW

 +1        QUIT 

 +2       ;

LODGER    ;

 +1        SET E=0

           if '$DATA(VAIP("L"))

               GOTO LODGERQ

 +2        IF VAX("DT")=VAX("DAT")

               SET VAX=$SELECT($DATA(^DPT(DFN,.107)):^(.107),1:"")

               if VAX']""

                   GOTO LODGERQ

               SET E=$SELECT($DATA(^DPT("LD",VAX,DFN)):+^(DFN),1:0)

               GOTO LODGERQ

 +3       ;

 +4        SET VAX=$ORDER(^DGPM("ATID4",DFN,9999999.999999-VAX("DT")))

           if VAX

               SET E=+$ORDER(^DGPM("ATID4",DFN,VAX,0))

 +5        IF E

               SET E=$SELECT($DATA(^DGPM(E,0)):E,1:0)

               IF E

                   IF $DATA(^DGPM(+$PIECE(^(0),"^",17),0))

                       IF ^(0)'>VAX("DT")

                           SET E=0

LODGERQ    QUIT 

 +1       ;

LLDCHK    ; -- last lodger mvt checking ; build array of inverse dates and chk

 +1        NEW IDT

           SET IDT(VAX)=0

 +2        SET IDT=+$ORDER(^DGPM("ATID4",DFN,NOWI))

           if IDT

               SET IDT(IDT)=+$ORDER(^(IDT,0))

 +3        SET IDT=+$ORDER(^DGPM("ATID5",DFN,NOWI))

           if IDT

               SET IDT(IDT)=+$ORDER(^(IDT,0))

 +4        SET IDT=+$ORDER(IDT(0))

           IF IDT

               SET E=IDT(IDT)

               SET E=$SELECT($DATA(^DGPM(E,0)):E,1:0)

 +5        QUIT 

 +6       ; 

CHK       ;

 +1        GOTO VAR^VADPT30

 +2       ;

ASIHOF    ; -- is last mvt asih oth fac

 +1        SET E=0

           SET VAX=$SELECT('$ORDER(^DGPM("APID",DFN,NOWI)):"",1:$ORDER(^DGPM("APID",DFN,$ORDER(^(NOWI)),0)))

 +2        IF VAX

               IF $DATA(^DGPM(VAX,0))

                   IF "^43^45^"[("^"_$PIECE(^(0),"^",18)_"^")

                       SET E=VAX

 +3        QUIT 

 +4       ;

42        ; -- check to see if this mvt can be used; for 'while asih' d/c category

 +1       ;   If Y returned high then mvt is good

 +2       ;

 +3       ; not a real d/c yet

           IF VAZ'<VAX("DAT")

               SET Y=0

               GOTO Q42

 +4       ; nhcu d/c assoicated w/asih d/c (seq #2)

           IF $PIECE(VAZ,"^",22)=2

               SET Y=0

               GOTO Q42

 +5        DO SCAN

Q42        QUIT 

 +1       ;

SCAN      ; -- determine is d/c while in other fac(Y=1 returned if so.)

 +1       ;

 +2        NEW VAID,VACA,M

           SET Y=0

           SET VAID=9999999.999999-VAZ

           SET VACA=+$PIECE(VAZ,"^",14)

 +3        FOR VAID=VAID:0

               SET VAID=$ORDER(^DGPM("APMV",DFN,VACA,VAID))

               if 'VAID

                   QUIT 

               IF $DATA(^DGPM(+$ORDER(^(VAID,0)),0))

                   SET M=$PIECE(^(0),"^",18)

                   IF "^13^44^43^45^"[("^"_M_"^")

                       SET Y=$SELECT(M=43!(M=45):1,1:0)

                       QUIT 

 +4        QUIT 

 +5       ;

47        ; -- check to see if d/c from nhcu while asih in other fac

 +1       ;   If y returned high then mvt is good.

 +2        DO SCAN

           QUIT 

 +3       ;

 +4       ; 13 = to asih (vah)     (xfr)|44 = resume asih in parent facility (xfr)

 +5       ; 41 = from asih         (d/c)|45 = change asih location(other fac)(xfr)

 +6       ; 42 = while asih        (d/c)|46 = continues asih (other fac)     (d/c)

 +7       ; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)