- 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 Feb 19, 2025@00:18:27 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 ;