DGPTFM7 ;ALB/MJ/PLT - Display Phys. MPCR mvts ; 11/30/06 8:31am
;;5.3;Registration;**78,590,594,683,729,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; entry pt to display MPCR screen
; -- PTF and DGPTFMT must be defined
;
S DGMAX=7,DGPTIFN=PTF,DGTOT=0 G BYPASS:DGPTFMT<2
D FDT^DGPTUTL S DGFMTDT=Y
F NODE=535,"M" F I=0:0 S I=$O(^DGPT(DGPTIFN,NODE,I)) Q:'I I $D(^(I,0)) S Y=$S($P(^(0),U,10):$P(^(0),U,10),1:DT+.2359),^UTILITY($J,"DGCDR",Y)=NODE_U_I,^UTILITY($J,"DG"_NODE,Y)=I
S P=$S('$D(^DGPT(DGPTIFN,0)):DGFMTDT+1,$P(^(0),U,2)>DGFMTDT:$P(^(0),U,2),1:DGFMTDT)
F I=0:0 S I=$O(^UTILITY($J,"DGCDR",I)) Q:'I I I>DGFMTDT S DGTOT=DGTOT+1,^(I)=^(I)_"^"_P,P=I
BYPASS S (DGC,DGLDT)=0
LOOP ;
D HEADER:$Y>(IOSL-15) S DGLAST("DT")=DGLDT,DGLAST("C")=DGC
I DGPTFMT<2 W !!," MPCR information not required for this admission."
F DGLDT=DGLDT:0 S DGLDT=$O(^UTILITY($J,"DGCDR",DGLDT)) Q:'DGLDT I DGLDT>DGFMTDT S X=^(DGLDT) D PRT I 'DGPR Q:'(DGC#DGMAX)!(DGC=DGTOT)
I DGPR D KILL Q
W:DGC<DGTOT !,"...more movements available"
F I=$Y:1:18 W !
;
K X S $P(X,"-",81)="" W X
I $D(DGBRCH) G @DGBRCH
W !,"Enter <RET> to ",$S(DGC'<DGTOT:"go to MAS screen",1:"display more MPCR information"),!," '^N' to go to screen N, or '^' to abort: <",$S(DGC'<DGTOT:"MAS",1:"RET"),">// " R X:DTIME S:'$T X="^",DGPTOUT=""
I X="^" D KILL G Q^DGPTF
I X="",DGC<DGTOT G LOOP
S:X="" X="^MAS"
I X?1"^".E D KILL S DGPTSCRN="CDR" G ^DGPTFJ
;
HELP ; -- screen help
I DGC<DGTOT W !,"Press return to see more MPCR information"
I DGC'<DGTOT W !,"Press return to go to the 'MAS' screen"
W !," '^' to stop the display"
W !," '^N' to jump to screen #N (appears in upper right of screen '<N>')"
R !!,"Enter <RET>: ",X:DTIME
S DGC=DGLAST("C"),DGLDT=DGLAST("DT") G LOOP
;
KILL ; -- kill off locals
K ^UTILITY($J,"DGCDR"),^("DG535"),^("DGM"),DGCDR,DGC,DGI0,DGICDR,DGLDT,DGLVE,DGPASS,DG5SP,DG5CDR,DGMSP,DGMCDR,DGMDRG,DGMAX,DGTOT,DGWARD,DGPTIFN,DGLAST,DGFMTDT,DGLDTE,DGCDR0,DGM0,DGMTY,P,I
Q
;
I DGPR D HEAD^DGPTFMO
I 'DGPR W @IOF,HEAD,?72 S Z="<MPCR>" D Z^DGPTFM
W !?23,"Rec",?38,"Losing Ward",?54,"PTF"
W !?4,"Losing Date",?23,"Type",?28,"Ward/DRG",?38,"MPCR/Spec",?54,"MPCR/Spec",?68,"Lve/Pas/ Los"
W !,"--------------------------------------------------------------------------------"
Q
;
PRT ; -- collect 501 and 535 data and then print
;
I $P(X,U)="M" S DGMTY=501,(Z,DGM0)=^DGPT(DGPTIFN,"M",+$P(X,U,2),0),DGMDRG=$S($D(^("P")):$P(^("P"),U),1:""),Y=+$O(^UTILITY($J,"DG535",DGLDT-.0000001)),DGCDR0=$S('$D(^(Y)):"",$D(^DGPT(DGPTIFN,535,+^(Y),0)):^(0),1:"")
;
I $P(X,U)="535" S DGMTY=535,(Z,DGCDR0)=^DGPT(DGPTIFN,535,+$P(X,U,2),0),Y=+$O(^UTILITY($J,"DGM",DGLDT-.0000001)),DGM0=$S('$D(^(Y)):"",$D(^DGPT(DGPTIFN,"M",+^(Y),0)):^(0),1:""),DGMDRG=""
;
N DGLOS S X1=DGLDT,X2=$P(X,U,3) D ^%DTC S X=X-$P(Z,U,3),DGLOS=$J($S(X>0:X,1:1),4)
S DGC=DGC+1,DGLVE=$J($P(Z,U,3),3),DGPASS=$J($P(Z,U,4),3)
S Y=DGLDT X ^DD("DD") S DGLDTE=Y
;S DGMSP=$E($S($D(^DIC(42.4,+$P(DGM0,U,2),0)):$P(^(0),U),1:"UNKNOWN"),1,14),DGMCDR=$J(+$P(DGM0,U,16),7,2)
;S DG5SP=$E($S($D(^DIC(42.4,+$P(DGCDR0,U,2),0)):$P(^(0),U),1:"UNKNOWN"),1,14),DG5CDR=$J(+$P(DGCDR0,U,16),7,2)
I $D(^DIC(42.4,+$P(DGM0,U,2),0)) D
. S DGMSP=$P(^DIC(42.4,+$P(DGM0,U,2),0),"^",2)
. I DGMSP="" S DGMSP=$P(^DIC(42.4,+$P(DGM0,U,2),0),"^")
. S DGMSP=$E(DGMSP,1,14)
E S DGMSP="UNKNOWN"
S DGMCDR=$J(+$P(DGM0,U,16),7,2)
I $D(^DIC(42.4,+$P(DGCDR0,U,2),0)) D
. S DG5SP=$P(^DIC(42.4,+$P(DGCDR0,U,2),0),"^",2)
. I DG5SP="" S DG5SP=$P(^DIC(42.4,+$P(DGCDR0,U,2),0),"^")
. S DG5SP=$E(DG5SP,1,14)
E S DG5SP="UNKNOWN"
S DG5CDR=$J(+$P(DGCDR0,U,16),7,2)
S DGWARD=$E($S($D(^DIC(42,+$P(DGCDR0,U,6),0)):$P(^(0),U),1:"UNKNOWN"),1,8)
;
W !,$J(DGC,3),?4,DGLDTE,?23,DGMTY,?28,DGWARD,?38,DG5CDR,?54,DGMCDR,?68,DGLVE,"/",DGPASS,"/",DGLOS,!?28,DGMDRG,?38,DG5SP,?54,DGMSP
Q
;
INQ ; -- entry point for inquire option
;
S:'$D(DC) DC=0 S PTF=D0,DGPR=1 D EN,KILL K PTF Q:$Y<(IOSL-15)
I $E(IOST,1)="C" W *7 R X:DTIME I X=U S DN=0 Q
W @IOF,! X:$D(^UTILITY($J,2)) ^(2) W ! F %=1:1:IOM W "_"
W !,"("_$P(^DPT(+^DGPT(D0,0),0),U,1)_")",!
Q
DT I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))," " W:Y#100 $J(Y#100\1,2),"," W Y\10000+1700 W:Y#1 " ",$E(Y_0,9,10),":",$E(Y_"000",11,12)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM7 4393 printed Jan 18, 2025@03:53:06 Page 2
DGPTFM7 ;ALB/MJ/PLT - Display Phys. MPCR mvts ; 11/30/06 8:31am
+1 ;;5.3;Registration;**78,590,594,683,729,884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; entry pt to display MPCR screen
+1 ; -- PTF and DGPTFMT must be defined
+2 ;
+3 SET DGMAX=7
SET DGPTIFN=PTF
SET DGTOT=0
if DGPTFMT<2
GOTO BYPASS
+4 DO FDT^DGPTUTL
SET DGFMTDT=Y
+5 FOR NODE=535,"M"
FOR I=0:0
SET I=$ORDER(^DGPT(DGPTIFN,NODE,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET Y=$SELECT($PIECE(^(0),U,10):$PIECE(^(0),U,10),1:DT+.2359)
SET ^UTILITY($JOB,"DGCDR",Y)=NODE_U_I
SET ^UTILITY($JOB,"DG"_NODE,Y)=I
+6 SET P=$SELECT('$DATA(^DGPT(DGPTIFN,0)):DGFMTDT+1,$PIECE(^(0),U,2)>DGFMTDT:$PIECE(^(0),U,2),1:DGFMTDT)
+7 FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"DGCDR",I))
if 'I
QUIT
IF I>DGFMTDT
SET DGTOT=DGTOT+1
SET ^(I)=^(I)_"^"_P
SET P=I
BYPASS SET (DGC,DGLDT)=0
LOOP ;
+1 if $Y>(IOSL-15)
DO HEADER
SET DGLAST("DT")=DGLDT
SET DGLAST("C")=DGC
+2 IF DGPTFMT<2
WRITE !!," MPCR information not required for this admission."
+3 FOR DGLDT=DGLDT:0
SET DGLDT=$ORDER(^UTILITY($JOB,"DGCDR",DGLDT))
if 'DGLDT
QUIT
IF DGLDT>DGFMTDT
SET X=^(DGLDT)
DO PRT
IF 'DGPR
if '(DGC#DGMAX)!(DGC=DGTOT)
QUIT
+4 IF DGPR
DO KILL
QUIT
+5 if DGC<DGTOT
WRITE !,"...more movements available"
+6 FOR I=$Y:1:18
WRITE !
+7 ;
+8 KILL X
SET $PIECE(X,"-",81)=""
WRITE X
+9 IF $DATA(DGBRCH)
GOTO @DGBRCH
+10 WRITE !,"Enter <RET> to ",$SELECT(DGC'<DGTOT:"go to MAS screen",1:"display more MPCR information"),!," '^N' to go to screen N, or '^' to abort: <",$SELECT(DGC'<DGTOT:"MAS",1:"RET"),">// "
READ X:DTIME
if '$TEST
SET X="^"
SET DGPTOUT=""
+11 IF X="^"
DO KILL
GOTO Q^DGPTF
+12 IF X=""
IF DGC<DGTOT
GOTO LOOP
+13 if X=""
SET X="^MAS"
+14 IF X?1"^".E
DO KILL
SET DGPTSCRN="CDR"
GOTO ^DGPTFJ
+15 ;
HELP ; -- screen help
+1 IF DGC<DGTOT
WRITE !,"Press return to see more MPCR information"
+2 IF DGC'<DGTOT
WRITE !,"Press return to go to the 'MAS' screen"
+3 WRITE !," '^' to stop the display"
+4 WRITE !," '^N' to jump to screen #N (appears in upper right of screen '<N>')"
+5 READ !!,"Enter <RET>: ",X:DTIME
+6 SET DGC=DGLAST("C")
SET DGLDT=DGLAST("DT")
GOTO LOOP
+7 ;
KILL ; -- kill off locals
+1 KILL ^UTILITY($JOB,"DGCDR"),^("DG535"),^("DGM"),DGCDR,DGC,DGI0,DGICDR,DGLDT,DGLVE,DGPASS,DG5SP,DG5CDR,DGMSP,DGMCDR,DGMDRG,DGMAX,DGTOT,DGWARD,DGPTIFN,DGLAST,DGFMTDT,DGLDTE,DGCDR0,DGM0,DGMTY,P,I
+2 QUIT
+3 ;
+1 IF DGPR
DO HEAD^DGPTFMO
+2 IF 'DGPR
WRITE @IOF,HEAD,?72
SET Z="<MPCR>"
DO Z^DGPTFM
+3 WRITE !?23,"Rec",?38,"Losing Ward",?54,"PTF"
+4 WRITE !?4,"Losing Date",?23,"Type",?28,"Ward/DRG",?38,"MPCR/Spec",?54,"MPCR/Spec",?68,"Lve/Pas/ Los"
+5 WRITE !,"--------------------------------------------------------------------------------"
+6 QUIT
+7 ;
PRT ; -- collect 501 and 535 data and then print
+1 ;
+2 IF $PIECE(X,U)="M"
SET DGMTY=501
SET (Z,DGM0)=^DGPT(DGPTIFN,"M",+$PIECE(X,U,2),0)
SET DGMDRG=$SELECT($DATA(^("P")):$PIECE(^("P"),U),1:"")
SET Y=+$ORDER(^UTILITY($JOB,"DG535",DGLDT-.0000001))
SET DGCDR0=$SELECT('$DATA(^(Y)):"",$DATA(^DGPT(DGPTIFN,535,+^(Y),0)):^(0),1:"")
+3 ;
+4 IF $PIECE(X,U)="535"
SET DGMTY=535
SET (Z,DGCDR0)=^DGPT(DGPTIFN,535,+$PIECE(X,U,2),0)
SET Y=+$ORDER(^UTILITY($JOB,"DGM",DGLDT-.0000001))
SET DGM0=$SELECT('$DATA(^(Y)):"",$DATA(^DGPT(DGPTIFN,"M",+^(Y),0)):^(0),1:"")
SET DGMDRG=""
+5 ;
+6 NEW DGLOS
SET X1=DGLDT
SET X2=$PIECE(X,U,3)
DO ^%DTC
SET X=X-$PIECE(Z,U,3)
SET DGLOS=$JUSTIFY($SELECT(X>0:X,1:1),4)
+7 SET DGC=DGC+1
SET DGLVE=$JUSTIFY($PIECE(Z,U,3),3)
SET DGPASS=$JUSTIFY($PIECE(Z,U,4),3)
+8 SET Y=DGLDT
XECUTE ^DD("DD")
SET DGLDTE=Y
+9 ;S DGMSP=$E($S($D(^DIC(42.4,+$P(DGM0,U,2),0)):$P(^(0),U),1:"UNKNOWN"),1,14),DGMCDR=$J(+$P(DGM0,U,16),7,2)
+10 ;S DG5SP=$E($S($D(^DIC(42.4,+$P(DGCDR0,U,2),0)):$P(^(0),U),1:"UNKNOWN"),1,14),DG5CDR=$J(+$P(DGCDR0,U,16),7,2)
+11 IF $DATA(^DIC(42.4,+$PIECE(DGM0,U,2),0))
Begin DoDot:1
+12 SET DGMSP=$PIECE(^DIC(42.4,+$PIECE(DGM0,U,2),0),"^",2)
+13 IF DGMSP=""
SET DGMSP=$PIECE(^DIC(42.4,+$PIECE(DGM0,U,2),0),"^")
+14 SET DGMSP=$EXTRACT(DGMSP,1,14)
End DoDot:1
+15 IF '$TEST
SET DGMSP="UNKNOWN"
+16 SET DGMCDR=$JUSTIFY(+$PIECE(DGM0,U,16),7,2)
+17 IF $DATA(^DIC(42.4,+$PIECE(DGCDR0,U,2),0))
Begin DoDot:1
+18 SET DG5SP=$PIECE(^DIC(42.4,+$PIECE(DGCDR0,U,2),0),"^",2)
+19 IF DG5SP=""
SET DG5SP=$PIECE(^DIC(42.4,+$PIECE(DGCDR0,U,2),0),"^")
+20 SET DG5SP=$EXTRACT(DG5SP,1,14)
End DoDot:1
+21 IF '$TEST
SET DG5SP="UNKNOWN"
+22 SET DG5CDR=$JUSTIFY(+$PIECE(DGCDR0,U,16),7,2)
+23 SET DGWARD=$EXTRACT($SELECT($DATA(^DIC(42,+$PIECE(DGCDR0,U,6),0)):$PIECE(^(0),U),1:"UNKNOWN"),1,8)
+24 ;
+25 WRITE !,$JUSTIFY(DGC,3),?4,DGLDTE,?23,DGMTY,?28,DGWARD,?38,DG5CDR,?54,DGMCDR,?68,DGLVE,"/",DGPASS,"/",DGLOS,!?28,DGMDRG,?38,DG5SP,?54,DGMSP
+26 QUIT
+27 ;
INQ ; -- entry point for inquire option
+1 ;
+2 if '$DATA(DC)
SET DC=0
SET PTF=D0
SET DGPR=1
DO EN
DO KILL
KILL PTF
if $Y<(IOSL-15)
QUIT
+3 IF $EXTRACT(IOST,1)="C"
WRITE *7
READ X:DTIME
IF X=U
SET DN=0
QUIT
+4 WRITE @IOF,!
if $DATA(^UTILITY($JOB,2))
XECUTE ^(2)
WRITE !
FOR %=1:1:IOM
WRITE "_"
+5 WRITE !,"("_$PIECE(^DPT(+^DGPT(D0,0),0),U,1)_")",!
+6 QUIT
DT IF Y
WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))," "
if Y#100
WRITE $JUSTIFY(Y#100\1,2),","
WRITE Y\10000+1700
if Y#1
WRITE " ",$EXTRACT(Y_0,9,10),":",$EXTRACT(Y_"000",11,12)
+1 QUIT
+2 ;
