- 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 Jan 18, 2025@03:54:27 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 ;