DIP5 ;SFISC/GFT-INITIALIZE TO PROCESS THE PRINT ;01:09 PM 13 Feb 2002 [ 12/09/2003 4:17 PM ]
;;22.0;VA FileMan;**32,97,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S %H=$H D YMD^%DTC S DT=X K %H,^UTILITY($J),^("DIL",$J)
I $G(DIFIXPT)=1 D G GO
. S ^UTILITY($J,1)="S DIFIXPTH="""_DHD_""",DC=1"
. Q
U IO
S Z=IOM-33,DIOSL=IOSL,M=$P("I 1 S Y=1,DIFF=1 W:DC?.N $C(7) R:DC?.N Y:DTIME S:'$T Y=U S:Y=U (DN,S)=0 I Y'=U ",U,IOST?1"C".E)
I M]"",DHD="@@" S M=M_"S $Y=0 "
S ^UTILITY($J,1)=M_"S DC=$P(DC,"","",2)+DC+1",M=DHD?1"W ".E
I DHD'="@@" S ^UTILITY($J,1)=^(1)_" W:$D(DIFF)&($Y) "_IOF_$P(",#",U,IOF'["#"),A1="S DIFF=1,$X=0,$Y=0" S:$L(^UTILITY($J,1))+$L(A1)>200 ^(1.3)=A1,A1="X ^(1.3)" S ^(1)=^(1)_" "_A1 K A1
I W S ^(1)=^(1)_" W $C(7)"_$S(F:"",1:" U """_IO(0)_"""")_" R Y"_$S(F:"",1:" U IO")_" W """""
I M S ^(1)=^(1)_" X ^(1.5)",^(1.5)=DHD G GO
I DHD'?.P1"[".E1"]",DHD'?1"@".E D
.N D,X,% S M=$P($H,C,2)\60,^UTILITY($J,2)=","_$E("!",$L(DHD)+2'<Z)_"?"_Z_" S Y="_(M#60/100+(M\60)/100+DT)_" D DT W "" PAGE "",DC",D=3
.I DIPCRIT S X="",%=0 D
..N A,B,S S (B,S)=1
..F S %=$O(DISTXT(%)) D:'% AS Q:'% S A=$G(DISTXT(%,0)) I A]"" S A=$$CONVQQ^DILIBF(A) D:$L(X)+$L(A)+20>IOM AS S X=X_$P(", ^",U,(X]""))_A
..S S=1,B=2
..F S %=$O(DPP(%)) D:%="" AS Q:%="" S A=$G(DPP(%,"TXT")) I A]"" S A=$$CONVQQ^DILIBF(A) D:$L(X)+$L(A)+20>IOM AS S X=X_$P(", ^",U,(X]""))_A
..I $G(DIPZ) F S=3:1:D S A=$G(^UTILITY($J,S)) I A]"",$D(^(S+1)) S ^(S)=A_" X ^UTILITY($J,"_(S+1)_")"
..I DIPCRIT=1,D>3 S:$G(DIPZ) ^(D-1)=^UTILITY($J,D-1)_" X ^UTILITY($J,"_D_")" S ^UTILITY($J,D)="S DIPCRIT=0",D=D+1
..Q
.S %=$S($D(^UTILITY($J,3)):28,1:0),M="W """_DHD_"""" S:$L(M)+$L(^(2))+%>252 ^(2.5)=DHD,M="W ^(2.5)" S ^(2)=M_^(2)
.I $G(DIPZ),%>0 S ^(2)=^(2)_" X"_$P(":DIPCRIT^",U,(DIPCRIT=1))_" ^UTILITY($J,3)"
.S DHD=D Q
GO S X=0 F Y=$G(DPP(0))+1:1 Q:'$D(DPP(Y)) S X=X+1 D
. Q:$D(DPP(Y,"SER"))#2
. I X=1,'$O(DPP(Y)) Q:'$D(DPP(Y,"PTRIX")) Q:$O(DPP(Y,0))
. I $O(DPP(Y,0)) K:$D(DPP(Y,"PTRIX")) DPP(Y,"PTRIX"),DPP(Y,"IX") Q
. I $D(DPP(Y,"CM")),'$D(DPP(Y,"PTRIX")) Q
. N N,%,X,S S N=0,(%,X)="",S=$P(DPP(Y),U) Q:S<2
. I $P(DPP(Y),U,2)=.01!($P(DPP(Y),U,2)=0) I '$D(DPP(Y,"F")),'$D(DPP(Y,"T")) S (%,X)=0 G CAL
. D
.. N I S I=Y N Y,DIBT1
.. D SER^DIOQ(S,DPP(I,"GET"),DPP(I,"QCON"),$D(DPP(I,"IX"))#2,.X,.%,N)
.. Q
CAL .I $D(DPP(Y,"PTRIX")) D
.. N F,T,N S F=+$P($G(@(^DIC(+S,0,"GL")_"0)")),U,4)
.. S T=$P($G(^DD(+S,+$P($P(DPP(Y),U,4),"""",2),0)),U,3) Q:T="" S T=$P($G(@("^"_T_"0)")),U,4)
.. S N=$S(Y>($G(DPP(0))+1):2,$O(DPP(Y)):2,1:1)
.. I (T*(1-%)*N)>F S X=% K DPP(Y,"IX"),DPP(Y,"PTRIX")
.. Q
. Q:%="" Q:X="" S X=X_U_%,DPP(Y,"SER")=X
. I $G(DIBT1),$D(^DIBT(DIBT1,2,Y)) S ^DIBT(DIBT1,2,Y,"SER")=X
. Q
S X=0 F Y=1:1:DPP I $P(DPP(Y),U,4)["!" S X=1,DRK=1 Q
FIELDS K R G DIPZ:$D(DIPZ) D INIT S R=DE,DJ=-1 I X S (X,W)="",Y=",DRK",DRJ=0,DLN=3 K DNP D O^DIL
DIL D ^DIL:R]"" S DJ=$S(DIPT:+$O(^DIPT(DIPT,"F",DJ)),1:+$O(^UTILITY("DIP2",$J,DJ))) I DJ S R=^(DJ) G DIL
D UNSTACK^DIL:DM,A^DIL G ^DIL2
;
AS S:X]"" ^UTILITY($J,D)="W"_$P(":DIPCRIT^",U,DIPCRIT)_" !,?"_$S(S=1:"0,"_""""_$P("Search^Sort",U,B)_" Criteria: ",1:"15,"_"""")_X_"""",D=D+1,S=S+1
S X="" Q
;
INIT ;
D:'$D(DISYS) OS^DII K DIL,DIWR S DN=-2,(DIL,DIL0,DIWL,DIO,DIO("SCR"),DM,DG,DX,DHT,DLN)=0,DY="D0",DI=DK_DY,@("DP=+$P("_DK_"0),U,2)"),M(DP)=1,DP(0)=DP,F="",Y=$S($D(^DD("OS"))[0!'$D(^DD("OS",DISYS,0)):0,1:$P(^(0),U,2)),DISMIN=99999
S DISEARCH=0 ; Initialize SEARCH Switch SO-2/24/2000
Q
;
DIPZ I $S('$D(^DIPT(DIPZ,"ROU")):1,^("ROU")'[U:1,'$D(^("IOM")):1,1:^("IOM")>IOM)!X S Y=DIPZ D F^DIP21 K DIPZ G GO
S Y=DIPZ D F^DIP21 S DK=DCC D INIT S ^UTILITY($J,99,1)="D "_^DIPT(DIPZ,"ROU"),DX=1
S X="" F DG=0:0 S X=$O(^DIPT(DIPZ,"STATS",X)) Q:X="" S %X="^DIPT(DIPZ,""STATS"",X,",%Y=X_"(" D %XY^%RCR
F X=-1:0 S X=$O(^DIPT(DIPZ,"T",X)) Q:'X S ^UTILITY($J,"T",X)=^(X)
F X=-1:0 S X=$O(DPQ(X)) Q:X="" F %=-1:0 S %=$O(DPQ(X,%)) Q:%="" K:$D(^DIPT("AF",X,$S(%:%,1:.001),DIPZ)) DPQ(X,%)
G ^DIL2
DIP5 ;SFISC/GFT-INITIALIZE TO PROCESS THE PRINT ;01:09 PM 13 Feb 2002 [ 12/09/2003 4:17 PM ]
+1 ;;22.0;VA FileMan;**32,97,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET %H=$HOROLOG
DO YMD^%DTC
SET DT=X
KILL %H,^UTILITY($JOB),^("DIL",$JOB)
+4 IF $GET(DIFIXPT)=1
Begin DoDot:1
+5 SET ^UTILITY($JOB,1)="S DIFIXPTH="""_DHD_""",DC=1"
+6 QUIT
End DoDot:1
GOTO GO
+7 USE IO
+8 SET Z=IOM-33
SET DIOSL=IOSL
SET M=$PIECE("I 1 S Y=1,DIFF=1 W:DC?.N $C(7) R:DC?.N Y:DTIME S:'$T Y=U S:Y=U (DN,S)=0 I Y'=U ",U,IOST?1"C".E)
+9 IF M]""
IF DHD="@@"
SET M=M_"S $Y=0 "
+10 SET ^UTILITY($JOB,1)=M_"S DC=$P(DC,"","",2)+DC+1"
SET M=DHD?1"W ".E
+11 IF DHD'="@@"
SET ^UTILITY($JOB,1)=^(1)_" W:$D(DIFF)&($Y) "_IOF_$PIECE(",#",U,IOF'["#")
SET A1="S DIFF=1,$X=0,$Y=0"
IF $LENGTH(^UTILITY($JOB,1))+$LENGTH(A1)>200
SET ^(1.3)=A1
SET A1="X ^(1.3)"
SET ^(1)=^(1)_" "_A1
KILL A1
+12 IF W
SET ^(1)=^(1)_" W $C(7)"_$SELECT(F:"",1:" U """_IO(0)_"""")_" R Y"_$SELECT(F:"",1:" U IO")_" W """""
+13 IF M
SET ^(1)=^(1)_" X ^(1.5)"
SET ^(1.5)=DHD
GOTO GO
+14 IF DHD'?.P1"[".E1"]"
IF DHD'?1"@".E
Begin DoDot:1
+15 NEW D,X,%
SET M=$PIECE($HOROLOG,C,2)\60
SET ^UTILITY($JOB,2)=","_$EXTRACT("!",$LENGTH(DHD)+2'<Z)_"?"_Z_" S Y="_(M#60/100+(M\60)/100+DT)_" D DT W "" PAGE "",DC"
SET D=3
+16 IF DIPCRIT
SET X=""
SET %=0
Begin DoDot:2
+17 NEW A,B,S
SET (B,S)=1
+18 FOR
SET %=$ORDER(DISTXT(%))
IF '%
DO AS
IF '%
QUIT
SET A=$GET(DISTXT(%,0))
IF A]""
SET A=$$CONVQQ^DILIBF(A)
IF $LENGTH(X)+$LENGTH(A)+20>IOM
DO AS
SET X=X_$PIECE(", ^",U,(X]""))_A
+19 SET S=1
SET B=2
+20 FOR
SET %=$ORDER(DPP(%))
IF %=""
DO AS
IF %=""
QUIT
SET A=$GET(DPP(%,"TXT"))
IF A]""
SET A=$$CONVQQ^DILIBF(A)
IF $LENGTH(X)+$LENGTH(A)+20>IOM
DO AS
SET X=X_$PIECE(", ^",U,(X]""))_A
+21 IF $GET(DIPZ)
FOR S=3:1:D
SET A=$GET(^UTILITY($JOB,S))
IF A]""
IF $DATA(^(S+1))
SET ^(S)=A_" X ^UTILITY($J,"_(S+1)_")"
+22 IF DIPCRIT=1
IF D>3
IF $GET(DIPZ)
SET ^(D-1)=^UTILITY($JOB,D-1)_" X ^UTILITY($J,"_D_")"
SET ^UTILITY($JOB,D)="S DIPCRIT=0"
SET D=D+1
+23 QUIT
End DoDot:2
+24 SET %=$SELECT($DATA(^UTILITY($JOB,3)):28,1:0)
SET M="W """_DHD_""""
IF $LENGTH(M)+$LENGTH(^(2))+%>252
SET ^(2.5)=DHD
SET M="W ^(2.5)"
SET ^(2)=M_^(2)
+25 IF $GET(DIPZ)
IF %>0
SET ^(2)=^(2)_" X"_$PIECE(":DIPCRIT^",U,(DIPCRIT=1))_" ^UTILITY($J,3)"
+26 SET DHD=D
QUIT
End DoDot:1
GO SET X=0
FOR Y=$GET(DPP(0))+1:1
IF '$DATA(DPP(Y))
QUIT
SET X=X+1
Begin DoDot:1
+1 IF $DATA(DPP(Y,"SER"))#2
QUIT
+2 IF X=1
IF '$ORDER(DPP(Y))
IF '$DATA(DPP(Y,"PTRIX"))
QUIT
IF $ORDER(DPP(Y,0))
QUIT
+3 IF $ORDER(DPP(Y,0))
IF $DATA(DPP(Y,"PTRIX"))
KILL DPP(Y,"PTRIX"),DPP(Y,"IX")
QUIT
+4 IF $DATA(DPP(Y,"CM"))
IF '$DATA(DPP(Y,"PTRIX"))
QUIT
+5 NEW N,%,X,S
SET N=0
SET (%,X)=""
SET S=$PIECE(DPP(Y),U)
IF S<2
QUIT
+6 IF $PIECE(DPP(Y),U,2)=.01!($PIECE(DPP(Y),U,2)=0)
IF '$DATA(DPP(Y,"F"))
IF '$DATA(DPP(Y,"T"))
SET (%,X)=0
GOTO CAL
+7 Begin DoDot:2
+8 NEW I
SET I=Y
NEW Y,DIBT1
+9 DO SER^DIOQ(S,DPP(I,"GET"),DPP(I,"QCON"),$DATA(DPP(I,"IX"))#2,.X,.%,N)
+10 QUIT
End DoDot:2
CAL IF $DATA(DPP(Y,"PTRIX"))
Begin DoDot:2
+1 NEW F,T,N
SET F=+$PIECE($GET(@(^DIC(+S,0,"GL")_"0)")),U,4)
+2 SET T=$PIECE($GET(^DD(+S,+$PIECE($PIECE(DPP(Y),U,4),"""",2),0)),U,3)
IF T=""
QUIT
SET T=$PIECE($GET(@("^"_T_"0)")),U,4)
+3 SET N=$SELECT(Y>($GET(DPP(0))+1):2,$ORDER(DPP(Y)):2,1:1)
+4 IF (T*(1-%)*N)>F
SET X=%
KILL DPP(Y,"IX"),DPP(Y,"PTRIX")
+5 QUIT
End DoDot:2
+6 IF %=""
QUIT
IF X=""
QUIT
SET X=X_U_%
SET DPP(Y,"SER")=X
+7 IF $GET(DIBT1)
IF $DATA(^DIBT(DIBT1,2,Y))
SET ^DIBT(DIBT1,2,Y,"SER")=X
+8 QUIT
End DoDot:1
+9 SET X=0
FOR Y=1:1:DPP
IF $PIECE(DPP(Y),U,4)["!"
SET X=1
SET DRK=1
QUIT
FIELDS KILL R
IF $DATA(DIPZ)
GOTO DIPZ
DO INIT
SET R=DE
SET DJ=-1
IF X
SET (X,W)=""
SET Y=",DRK"
SET DRJ=0
SET DLN=3
KILL DNP
DO O^DIL
DIL IF R]""
DO ^DIL
SET DJ=$SELECT(DIPT:+$ORDER(^DIPT(DIPT,"F",DJ)),1:+$ORDER(^UTILITY("DIP2",$JOB,DJ)))
IF DJ
SET R=^(DJ)
GOTO DIL
+1 IF DM
DO UNSTACK^DIL
DO A^DIL
GOTO ^DIL2
+2 ;
AS IF X]""
SET ^UTILITY($JOB,D)="W"_$PIECE(":DIPCRIT^",U,DIPCRIT)_" !,?"_$SELECT(S=1:"0,"_""""_$PIECE("Search^Sort",U,B)_" Criteria: ",1:"15,"_"""")_X_""""
SET D=D+1
SET S=S+1
+1 SET X=""
QUIT
+2 ;
INIT ;
+1 IF '$DATA(DISYS)
DO OS^DII
KILL DIL,DIWR
SET DN=-2
SET (DIL,DIL0,DIWL,DIO,DIO("SCR"),DM,DG,DX,DHT,DLN)=0
SET DY="D0"
SET DI=DK_DY
SET @("DP=+$P("_DK_"0),U,2)")
SET M(DP)=1
SET DP(0)=DP
SET F=""
SET Y=$SELECT($DATA(^DD("OS"))[0!'$DATA(^DD("OS",DISYS,0)):0,1:$PIECE(^(0),U,2))
SET DISMIN=99999
+2 ; Initialize SEARCH Switch SO-2/24/2000
SET DISEARCH=0
+3 QUIT
+4 ;
DIPZ IF $SELECT('$DATA(^DIPT(DIPZ,"ROU")):1,^("ROU")'[U:1,'$DATA(^("IOM")):1,1:^("IOM")>IOM)!X
SET Y=DIPZ
DO F^DIP21
KILL DIPZ
GOTO GO
+1 SET Y=DIPZ
DO F^DIP21
SET DK=DCC
DO INIT
SET ^UTILITY($JOB,99,1)="D "_^DIPT(DIPZ,"ROU")
SET DX=1
+2 SET X=""
FOR DG=0:0
SET X=$ORDER(^DIPT(DIPZ,"STATS",X))
IF X=""
QUIT
SET %X="^DIPT(DIPZ,""STATS"",X,"
SET %Y=X_"("
DO %XY^%RCR
+3 FOR X=-1:0
SET X=$ORDER(^DIPT(DIPZ,"T",X))
IF 'X
QUIT
SET ^UTILITY($JOB,"T",X)=^(X)
+4 FOR X=-1:0
SET X=$ORDER(DPQ(X))
IF X=""
QUIT
FOR %=-1:0
SET %=$ORDER(DPQ(X,%))
IF %=""
QUIT
IF $DATA(^DIPT("AF",X,$SELECT(%
KILL DPQ(X,%)
+5 GOTO ^DIL2
