DGRPE4 ;ALB/GTS - REGISTRATIONS EDITS ; 5/25/05 08:53am
;;5.3;Registration;**624**;Aug 13, 1993
;
;DGDR contains a string of edits; edit=screen*10+item #
;
;line tag screen*10+item*1000 = continuation line
;
N DGPH,DGPHFLG,UPARROUT
S UPARROUT=0
K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
I (DGDR["401") DO
. S J1="A401"
. S DGDRD=$P($T(@J1),";;",2)
. D S
. D ^DIE
. I $D(Y)'=0 S UPARROUT=1
. I UPARROUT=0 DO
. . K DR,DA,Y,DIE
. . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
. . S J1="B401"
. . S DGDRD=$P($T(@J1),";;",2)
. . D S
. . S DIE("NO^")=""
. . D ^DIE
. . K DR,DA,Y,DIE
. . N DGEMPST
. . S DGEMPST=(+$P($G(^DPT(DFN,.311)),"^",15))
. . I (DGEMPST]"")!(DGEMPST'=3)!(DGEMPST'=9) DO
. . . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
. . . S J1="C401"
. . . S DGDRD=$P($T(@J1),";;",2)
. . . D S
. . . D ^DIE
K DR,DA,Y,DIE
F Q:DGDR'["401," S DGDR=$P(DGDR,"401,")_""_$P(DGDR,"401,",2,999)
I (UPARROUT=0)&(DGDR["402") DO
. K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
. S J1="A402"
. S DGDRD=$P($T(@J1),";;",2)
. D S
. D ^DIE
. I $D(Y)'=0 S UPARROUT=1
. I UPARROUT=0 DO
. . K DR,DA,Y,DIE
. . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
. . S J1="B402"
. . S DGDRD=$P($T(@J1),";;",2)
. . D S
. . S DIE("NO^")=""
. . D ^DIE
. . K DR,DA,Y,DIE
. . N DGEMPST
. . S DGEMPST=(+$P($G(^DPT(DFN,.311)),"^",15))
. . I (DGEMPST]"")!(DGEMPST'=3)!(DGEMPST'=9) DO
. . . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
. . . S J1="C402"
. . . S DGDRD=$P($T(@J1),";;",2)
. . . D S
. . . D ^DIE
K DR,DA,Y,DIE
F Q:DGDR'["402," S DGDR=$P(DGDR,"402,")_""_$P(DGDR,"402,",2,999)
K DR,DA,Y,DIE
Q
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
Q
A401 ;;.07;
B401 ;;.31115;
C401 ;;S DGST=$P(^DPT(DA,.311),"^",15);S:$S(DGST']"":1,DGST=3:1,DGST=9:1,1:0) Y=0 I Y=0 K DGST;S:($P(^DPT(DA,.311),"^",15)'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;K DGST;
A402 ;;.2514;
B402 ;;.2515;
C402 ;;S DGST=$P(^DPT(DA,.25),"^",15);S:$S(DGST']"":1,DGST=3:1,DGST=9:1,1:0) Y=0 I Y=0 K DGST;S:($P(^DPT(DA,.25),"^",15)'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;K DGST;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPE4 2388 printed Oct 16, 2024@18:56:50 Page 2
DGRPE4 ;ALB/GTS - REGISTRATIONS EDITS ; 5/25/05 08:53am
+1 ;;5.3;Registration;**624**;Aug 13, 1993
+2 ;
+3 ;DGDR contains a string of edits; edit=screen*10+item #
+4 ;
+5 ;line tag screen*10+item*1000 = continuation line
+6 ;
+7 NEW DGPH,DGPHFLG,UPARROUT
+8 SET UPARROUT=0
+9 KILL DR
SET (DA,Y)=DFN
SET DIE="^DPT("
SET DR=""
SET DGDRS="DR"
SET DGCT=0
+10 IF (DGDR["401")
Begin DoDot:1
+11 SET J1="A401"
+12 SET DGDRD=$PIECE($TEXT(@J1),";;",2)
+13 DO S
+14 DO ^DIE
+15 IF $DATA(Y)'=0
SET UPARROUT=1
+16 IF UPARROUT=0
Begin DoDot:2
+17 KILL DR,DA,Y,DIE
+18 SET (DA,Y)=DFN
SET DIE="^DPT("
SET DR=""
SET DGDRS="DR"
SET DGCT=0
+19 SET J1="B401"
+20 SET DGDRD=$PIECE($TEXT(@J1),";;",2)
+21 DO S
+22 SET DIE("NO^")=""
+23 DO ^DIE
+24 KILL DR,DA,Y,DIE
+25 NEW DGEMPST
+26 SET DGEMPST=(+$PIECE($GET(^DPT(DFN,.311)),"^",15))
+27 IF (DGEMPST]"")!(DGEMPST'=3)!(DGEMPST'=9)
Begin DoDot:3
+28 SET (DA,Y)=DFN
SET DIE="^DPT("
SET DR=""
SET DGDRS="DR"
SET DGCT=0
+29 SET J1="C401"
+30 SET DGDRD=$PIECE($TEXT(@J1),";;",2)
+31 DO S
+32 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+33 KILL DR,DA,Y,DIE
+34 FOR
if DGDR'["401,"
QUIT
SET DGDR=$PIECE(DGDR,"401,")_""_$PIECE(DGDR,"401,",2,999)
+35 IF (UPARROUT=0)&(DGDR["402")
Begin DoDot:1
+36 KILL DR
SET (DA,Y)=DFN
SET DIE="^DPT("
SET DR=""
SET DGDRS="DR"
SET DGCT=0
+37 SET J1="A402"
+38 SET DGDRD=$PIECE($TEXT(@J1),";;",2)
+39 DO S
+40 DO ^DIE
+41 IF $DATA(Y)'=0
SET UPARROUT=1
+42 IF UPARROUT=0
Begin DoDot:2
+43 KILL DR,DA,Y,DIE
+44 SET (DA,Y)=DFN
SET DIE="^DPT("
SET DR=""
SET DGDRS="DR"
SET DGCT=0
+45 SET J1="B402"
+46 SET DGDRD=$PIECE($TEXT(@J1),";;",2)
+47 DO S
+48 SET DIE("NO^")=""
+49 DO ^DIE
+50 KILL DR,DA,Y,DIE
+51 NEW DGEMPST
+52 SET DGEMPST=(+$PIECE($GET(^DPT(DFN,.311)),"^",15))
+53 IF (DGEMPST]"")!(DGEMPST'=3)!(DGEMPST'=9)
Begin DoDot:3
+54 SET (DA,Y)=DFN
SET DIE="^DPT("
SET DR=""
SET DGDRS="DR"
SET DGCT=0
+55 SET J1="C402"
+56 SET DGDRD=$PIECE($TEXT(@J1),";;",2)
+57 DO S
+58 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+59 KILL DR,DA,Y,DIE
+60 FOR
if DGDR'["402,"
QUIT
SET DGDR=$PIECE(DGDR,"402,")_""_$PIECE(DGDR,"402,",2,999)
+61 KILL DR,DA,Y,DIE
+62 QUIT
S IF $LENGTH(@DGDRS)+$LENGTH(DGDRD)<241
SET @DGDRS=@DGDRS_DGDRD
QUIT
+1 SET DGCT=DGCT+1
SET DGDRS="DR(1,2,"_DGCT_")"
SET @DGDRS=DGDRD
QUIT
+2 QUIT
A401 ;;.07;
B401 ;;.31115;
C401 ;;S DGST=$P(^DPT(DA,.311),"^",15);S:$S(DGST']"":1,DGST=3:1,DGST=9:1,1:0) Y=0 I Y=0 K DGST;S:($P(^DPT(DA,.311),"^",15)'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;K DGST;
A402 ;;.2514;
B402 ;;.2515;
C402 ;;S DGST=$P(^DPT(DA,.25),"^",15);S:$S(DGST']"":1,DGST=3:1,DGST=9:1,1:0) Y=0 I Y=0 K DGST;S:($P(^DPT(DA,.25),"^",15)'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;K DGST;
