DGPTTS3 ;ALB/MJK - Physical Mvt ; 2/10/11 6:19pm
;;5.3;Registration;**26,61,549,729,787**;Aug 13, 1993;Build 1
;
EN ; -- entry used to update PTF rec
; input: PTF := PTF#
; DFN := pt#
; DGPMCA := adm mvt #
; DGDT := d/c date
;
S DGPTIFN=PTF
D FDT^DGPTUTL G ENQ:$S(DGDT:DGDT,1:DT)<Y
I '$D(ZTQUEUED),'$G(DGQUIET) W !,"Now updating ward MPCR information..."
S (DGBEG,DGSTART,DGLAST)=Y-.0000001
S X=Y I $E(X,6,7)="00" S X1=X,X2=-1 D C^%DTC
S DGPFYDT=$P(X,".")_".2359" ; last date/time in previous FY
D KILL
N DGRT S DGRT="^DGPM(""APCA"",DFN,DGPMCA)"
;
; -- build ward table
S DGDATA="",DGADM0=$S($D(^DGPM(DGPMCA,0)):^(0),1:"")
I DGADM0,DGADM0'>DGSTART S DGT=DGPFYDT D ^DGINPW I +DG1 S $P(DGXFR0,U,4)=+DG1 D TABLE
I DGADM0,DGADM0>DGSTART S $P(DGXFR0,U,4)=$P(DGADM0,U,6),DGBEG=+DGADM0 D TABLE
F DGXDT=DGSTART:0 S DGXDT=$O(@DGRT@(DGXDT)) Q:'DGXDT F DGMVT=0:0 S DGMVT=$O(@DGRT@(DGXDT,DGMVT)) Q:'DGMVT I $D(^DGPM(DGMVT,0)) S X=^(0) I $P(X,U,2)=2 S DGXFR0=$P(X,U,18)_"^^^"_$P(X,U,6) D TABLE
G ENQ:DGDATA=""
S DGEND=$S(DGDT:DGDT,1:DT) D DAYS S DGXDT=($S(DGDT:DGDT,1:"")),$P(DGDATA,U,3,4)=LEAVE_U_PASS,$P(DGDATA,U,7)=1 D CREATE
;
ENQ I $D(DGSACNT),DGSACNT>25 D FLCHK
S L=DGPTIFN
K DGRT,DGADM0,DG1,DGDATA,DGMDT,DGPTIFN,DGXFR0,DGXDT,DGM,X,DGM0,LEAVE,PASS,DGBEG,DGEND,DGSTART,DGWD,DGCDR,DGSP,DGADM0,DGPFYDT,DGT,DGA1,DGSAFTF,DGSACNT,DGWI,DGI
Q
;
TABLE ; -- setup 535 node data
; DGDATA := 1:ward cdr ^ 2:ward specialty ^ 3:leave days ^ 4:pass days ^ ^ 6:ward ^ ^ ^ ^ 10:mvt date/time
;
S DGWD=+$P(DGXFR0,U,4)
G TABLEQ:'$D(^DIC(42,DGWD,0)) S DGSP=+$P(^(0),U,12)
G TABLEQ:'$D(^DIC(42.4,DGSP,0)) S DGCDR=$P(^(0),U,6)
; -- create MPCR mvt if ward mpcr changes
I DGDATA]"",+DGDATA'=DGCDR S DGEND=DGXDT D DAYS S $P(DGDATA,U,3,4)=LEAVE_U_PASS D CREATE S DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD,DGLAST=DGBEG,DGBEG=DGEND
I DGDATA="",DGCDR]"" S DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD
TABLEQ Q
;
CREATE ; -- create MPCR mvt
F L +^DGPT(DGPTIFN,535):$G(DILOCKTM,3) Q:$T W !,"Another user is editing this record, trying again...",!
S Y=^DGPT(DGPTIFN,535,0),I=$P(Y,U,3)
L S I=I+1 G L:$D(^DGPT(DGPTIFN,535,I))
S $P(^DGPT(DGPTIFN,535,0),U,3,4)=I_U_($P(Y,U,4)+1)
S X=DGDATA,^DGPT(DGPTIFN,535,I,0)=I_U_$P(X,U,2)_U_$P(X,U,3)_U_$P(X,U,4)_"^^"_$P(X,U,6)_"^"_$P(X,U,7)_"^^^"_DGXDT L -^DGPT(DGPTIFN,535)
K DA S DA=I,DA(1)=DGPTIFN,DIK="^DGPT("_DGPTIFN_",535," D IX1^DIK
CREATEQ S DGSACNT=I
K DA,I,DIK Q
;
KILL ; -- clean out ward mvts
F DGWI=0:0 S DGWI=$O(^DGPT(DGPTIFN,535,DGWI)) Q:'DGWI S:$P(^(DGWI,0),U,17)="n" DGSAFTF(DGWI)=^(0) K DA S DA(1)=DGPTIFN,DA=DGWI,DIK="^DGPT("_DGPTIFN_",535," D ^DIK K DA
S:'$D(^DGPT(DGPTIFN,535,0)) ^(0)="^45.0535^"
K DIK,DGWI,DA Q
;
T ; -- test tag
S DIC(0)="AEMQZ",DIC=45,DIC("S")="I $P(^(0),U,11)=1" D ^DIC K DIC Q:Y<0
PTF S PTF=+Y,DGDT=$S($D(^DGPT(L,70)):+^(70),1:0),DFN=+Y(0) D PM^DGPTUTL,EN:DGPMCA
Q
;
DAYS ; -- calc leave and pass days from DGBEG to DGEND
; -- if last 501 date is after last 535 date then
; calc from last 535 mvt d/t to last 501 mvt d/t
;
; 535 501 501 535
; |------------|------|----------|
; <<<<<<<<<<< total >>>>>>>>>>
; <<<<<<< diff >>>>>>+<< pass >>
;
S (PASS,LEAVE,DGDIFP,DGDIFL)=0 D MVT
I DGMDT>DGBEG S DGE=DGEND,DGEND=DGMDT D DAYS0 S DGDIFL=LEAVE,DGDIFP=PASS,DGEND=DGE
; -- calc from last 535 mvt d/t to new 535 mvt d/t
S (PASS,LEAVE)=0 D DAYS0
; -- substract 'diff' from 'total'
S PASS=PASS-DGDIFP,LEAVE=LEAVE-DGDIFL
K DGDIFL,DGDIFP,DGE Q
;
DAYS0 ;
N DGMVT
F DGMVTDT=(DGBEG-.0000001):0 S DGMVTDT=$O(@DGRT@(DGMVTDT)) Q:'DGMVTDT F DGMVT=0:0 S DGMVT=$O(@DGRT@(DGMVTDT,DGMVT)) Q:'DGMVT I $D(^DGPM(DGMVT,0)),$P(^(0),U,2)=2 S C=$P(^(0),U,18) I C=1!(C=2)!(C=3) D NEXT,DAYS1
K DGMVTDT Q
;
DAYS1 S I=DGMVTDT,X2=$S(I<DGBEG:DGBEG,1:I),X1=$S(Y>DGBEG&(Y'>DGEND):Y,Y>DGEND!('Y):DGEND,1:X2)
I X1>X2 D ^%DTC S:C=1 PASS=PASS+X S:C=2 LEAVE=LEAVE+X
K C,X,Y,X1,X2,I
Q
;
NEXT ; -- find next x-ref date
N DGMVT
F Y=DGMVTDT:0 S Y=$O(@DGRT@(Y)) Q:'Y F DGMVT=0:0 S DGMVT=$O(@DGRT@(Y,DGMVT)) Q:'DGMVT I $D(^DGPM(DGMVT,0)),$P(^(0),U,2)=2 G NEXTQ
NEXTQ Q
;
MVT ; -- find last 501 mvt d/t since the last 535 mvt d/t
; and before the new 535 mvt d/t
S DGMDT=""
F M=DGLAST:0 S M=$O(^DGPT(DGPTIFN,"M","AM",M)) Q:'M!(M>DGEND) S DGMDT=M
K M Q
;
FLCHK ; -- check if more than 25 535s, then re-set x-mit flags
I '$D(DGSACNT) G FLQ
I DGSACNT<25 G FLQ
S DGF1=0
F DGWI=0:0 S DGWI=$O(DGSAFTF(DGWI)) Q:'DGWI!('$D(^DGPT(DGPTIFN,535,+DGWI,0))) F DGI=1,2,10,16 S:$P(^(0),U,DGI)'=$P(DGSAFTF(DGWI),U,DGI) DGF1=1
I 'DGF1,'DGWI F DGWI=0:0 S DGWI=$O(DGSAFTF(DGWI)) Q:'DGWI S DA=DGWI,DA(1)=DGPTIFN,DIE="^DGPT("_DGPTIFN_",535,",DR="17///n" D ^DIE
FLQ K DGI,DGF1,DGWI,DGSAFTF,DGSACNT,DR,DA,DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTTS3 4845 printed Oct 16, 2024@18:54:19 Page 2
DGPTTS3 ;ALB/MJK - Physical Mvt ; 2/10/11 6:19pm
+1 ;;5.3;Registration;**26,61,549,729,787**;Aug 13, 1993;Build 1
+2 ;
EN ; -- entry used to update PTF rec
+1 ; input: PTF := PTF#
+2 ; DFN := pt#
+3 ; DGPMCA := adm mvt #
+4 ; DGDT := d/c date
+5 ;
+6 SET DGPTIFN=PTF
+7 DO FDT^DGPTUTL
if $SELECT(DGDT:DGDT,1:DT)<Y
GOTO ENQ
+8 IF '$DATA(ZTQUEUED)
IF '$GET(DGQUIET)
WRITE !,"Now updating ward MPCR information..."
+9 SET (DGBEG,DGSTART,DGLAST)=Y-.0000001
+10 SET X=Y
IF $EXTRACT(X,6,7)="00"
SET X1=X
SET X2=-1
DO C^%DTC
+11 ; last date/time in previous FY
SET DGPFYDT=$PIECE(X,".")_".2359"
+12 DO KILL
+13 NEW DGRT
SET DGRT="^DGPM(""APCA"",DFN,DGPMCA)"
+14 ;
+15 ; -- build ward table
+16 SET DGDATA=""
SET DGADM0=$SELECT($DATA(^DGPM(DGPMCA,0)):^(0),1:"")
+17 IF DGADM0
IF DGADM0'>DGSTART
SET DGT=DGPFYDT
DO ^DGINPW
IF +DG1
SET $PIECE(DGXFR0,U,4)=+DG1
DO TABLE
+18 IF DGADM0
IF DGADM0>DGSTART
SET $PIECE(DGXFR0,U,4)=$PIECE(DGADM0,U,6)
SET DGBEG=+DGADM0
DO TABLE
+19 FOR DGXDT=DGSTART:0
SET DGXDT=$ORDER(@DGRT@(DGXDT))
if 'DGXDT
QUIT
FOR DGMVT=0:0
SET DGMVT=$ORDER(@DGRT@(DGXDT,DGMVT))
if 'DGMVT
QUIT
IF $DATA(^DGPM(DGMVT,0))
SET X=^(0)
IF $PIECE(X,U,2)=2
SET DGXFR0=$PIECE(X,U,18)_"^^^"_$PIECE(X,U,6)
DO TABLE
+20 if DGDATA=""
GOTO ENQ
+21 SET DGEND=$SELECT(DGDT:DGDT,1:DT)
DO DAYS
SET DGXDT=($SELECT(DGDT:DGDT,1:""))
SET $PIECE(DGDATA,U,3,4)=LEAVE_U_PASS
SET $PIECE(DGDATA,U,7)=1
DO CREATE
+22 ;
ENQ IF $DATA(DGSACNT)
IF DGSACNT>25
DO FLCHK
+1 SET L=DGPTIFN
+2 KILL DGRT,DGADM0,DG1,DGDATA,DGMDT,DGPTIFN,DGXFR0,DGXDT,DGM,X,DGM0,LEAVE,PASS,DGBEG,DGEND,DGSTART,DGWD,DGCDR,DGSP,DGADM0,DGPFYDT,DGT,DGA1,DGSAFTF,DGSACNT,DGWI,DGI
+3 QUIT
+4 ;
TABLE ; -- setup 535 node data
+1 ; DGDATA := 1:ward cdr ^ 2:ward specialty ^ 3:leave days ^ 4:pass days ^ ^ 6:ward ^ ^ ^ ^ 10:mvt date/time
+2 ;
+3 SET DGWD=+$PIECE(DGXFR0,U,4)
+4 if '$DATA(^DIC(42,DGWD,0))
GOTO TABLEQ
SET DGSP=+$PIECE(^(0),U,12)
+5 if '$DATA(^DIC(42.4,DGSP,0))
GOTO TABLEQ
SET DGCDR=$PIECE(^(0),U,6)
+6 ; -- create MPCR mvt if ward mpcr changes
+7 IF DGDATA]""
IF +DGDATA'=DGCDR
SET DGEND=DGXDT
DO DAYS
SET $PIECE(DGDATA,U,3,4)=LEAVE_U_PASS
DO CREATE
SET DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD
SET DGLAST=DGBEG
SET DGBEG=DGEND
+8 IF DGDATA=""
IF DGCDR]""
SET DGDATA=DGCDR_"^"_DGSP_"^^^^"_DGWD
TABLEQ QUIT
+1 ;
CREATE ; -- create MPCR mvt
+1 FOR
LOCK +^DGPT(DGPTIFN,535):$GET(DILOCKTM,3)
if $TEST
QUIT
WRITE !,"Another user is editing this record, trying again...",!
+2 SET Y=^DGPT(DGPTIFN,535,0)
SET I=$PIECE(Y,U,3)
L SET I=I+1
if $DATA(^DGPT(DGPTIFN,535,I))
GOTO L
+1 SET $PIECE(^DGPT(DGPTIFN,535,0),U,3,4)=I_U_($PIECE(Y,U,4)+1)
+2 SET X=DGDATA
SET ^DGPT(DGPTIFN,535,I,0)=I_U_$PIECE(X,U,2)_U_$PIECE(X,U,3)_U_$PIECE(X,U,4)_"^^"_$PIECE(X,U,6)_"^"_$PIECE(X,U,7)_"^^^"_DGXDT
LOCK -^DGPT(DGPTIFN,535)
+3 KILL DA
SET DA=I
SET DA(1)=DGPTIFN
SET DIK="^DGPT("_DGPTIFN_",535,"
DO IX1^DIK
CREATEQ SET DGSACNT=I
+1 KILL DA,I,DIK
QUIT
+2 ;
KILL ; -- clean out ward mvts
+1 FOR DGWI=0:0
SET DGWI=$ORDER(^DGPT(DGPTIFN,535,DGWI))
if 'DGWI
QUIT
if $PIECE(^(DGWI,0),U,17)="n"
SET DGSAFTF(DGWI)=^(0)
KILL DA
SET DA(1)=DGPTIFN
SET DA=DGWI
SET DIK="^DGPT("_DGPTIFN_",535,"
DO ^DIK
KILL DA
+2 if '$DATA(^DGPT(DGPTIFN,535,0))
SET ^(0)="^45.0535^"
+3 KILL DIK,DGWI,DA
QUIT
+4 ;
T ; -- test tag
+1 SET DIC(0)="AEMQZ"
SET DIC=45
SET DIC("S")="I $P(^(0),U,11)=1"
DO ^DIC
KILL DIC
if Y<0
QUIT
PTF SET PTF=+Y
SET DGDT=$SELECT($DATA(^DGPT(L,70)):+^(70),1:0)
SET DFN=+Y(0)
DO PM^DGPTUTL
if DGPMCA
DO EN
+1 QUIT
+2 ;
DAYS ; -- calc leave and pass days from DGBEG to DGEND
+1 ; -- if last 501 date is after last 535 date then
+2 ; calc from last 535 mvt d/t to last 501 mvt d/t
+3 ;
+4 ; 535 501 501 535
+5 ; |------------|------|----------|
+6 ; <<<<<<<<<<< total >>>>>>>>>>
+7 ; <<<<<<< diff >>>>>>+<< pass >>
+8 ;
+9 SET (PASS,LEAVE,DGDIFP,DGDIFL)=0
DO MVT
+10 IF DGMDT>DGBEG
SET DGE=DGEND
SET DGEND=DGMDT
DO DAYS0
SET DGDIFL=LEAVE
SET DGDIFP=PASS
SET DGEND=DGE
+11 ; -- calc from last 535 mvt d/t to new 535 mvt d/t
+12 SET (PASS,LEAVE)=0
DO DAYS0
+13 ; -- substract 'diff' from 'total'
+14 SET PASS=PASS-DGDIFP
SET LEAVE=LEAVE-DGDIFL
+15 KILL DGDIFL,DGDIFP,DGE
QUIT
+16 ;
DAYS0 ;
+1 NEW DGMVT
+2 FOR DGMVTDT=(DGBEG-.0000001):0
SET DGMVTDT=$ORDER(@DGRT@(DGMVTDT))
if 'DGMVTDT
QUIT
FOR DGMVT=0:0
SET DGMVT=$ORDER(@DGRT@(DGMVTDT,DGMVT))
if 'DGMVT
QUIT
IF $DATA(^DGPM(DGMVT,0))
IF $PIECE(^(0),U,2)=2
SET C=$PIECE(^(0),U,18)
IF C=1!(C=2)!(C=3)
DO NEXT
DO DAYS1
+3 KILL DGMVTDT
QUIT
+4 ;
DAYS1 SET I=DGMVTDT
SET X2=$SELECT(I<DGBEG:DGBEG,1:I)
SET X1=$SELECT(Y>DGBEG&(Y'>DGEND):Y,Y>DGEND!('Y):DGEND,1:X2)
+1 IF X1>X2
DO ^%DTC
if C=1
SET PASS=PASS+X
if C=2
SET LEAVE=LEAVE+X
+2 KILL C,X,Y,X1,X2,I
+3 QUIT
+4 ;
NEXT ; -- find next x-ref date
+1 NEW DGMVT
+2 FOR Y=DGMVTDT:0
SET Y=$ORDER(@DGRT@(Y))
if 'Y
QUIT
FOR DGMVT=0:0
SET DGMVT=$ORDER(@DGRT@(Y,DGMVT))
if 'DGMVT
QUIT
IF $DATA(^DGPM(DGMVT,0))
IF $PIECE(^(0),U,2)=2
GOTO NEXTQ
NEXTQ QUIT
+1 ;
MVT ; -- find last 501 mvt d/t since the last 535 mvt d/t
+1 ; and before the new 535 mvt d/t
+2 SET DGMDT=""
+3 FOR M=DGLAST:0
SET M=$ORDER(^DGPT(DGPTIFN,"M","AM",M))
if 'M!(M>DGEND)
QUIT
SET DGMDT=M
+4 KILL M
QUIT
+5 ;
FLCHK ; -- check if more than 25 535s, then re-set x-mit flags
+1 IF '$DATA(DGSACNT)
GOTO FLQ
+2 IF DGSACNT<25
GOTO FLQ
+3 SET DGF1=0
+4 FOR DGWI=0:0
SET DGWI=$ORDER(DGSAFTF(DGWI))
if 'DGWI!('$DATA(^DGPT(DGPTIFN,535,+DGWI,0)))
QUIT
FOR DGI=1,2,10,16
if $PIECE(^(0),U,DGI)'=$PIECE(DGSAFTF(DGWI),U,DGI)
SET DGF1=1
+5 IF 'DGF1
IF 'DGWI
FOR DGWI=0:0
SET DGWI=$ORDER(DGSAFTF(DGWI))
if 'DGWI
QUIT
SET DA=DGWI
SET DA(1)=DGPTIFN
SET DIE="^DGPT("_DGPTIFN_",535,"
SET DR="17///n"
DO ^DIE
FLQ KILL DGI,DGF1,DGWI,DGSAFTF,DGSACNT,DR,DA,DIE
+1 QUIT
+2 ;
