- DGRPE4 ;ALB/GTS - REGISTRATIONS EDITS ; 5/25/05 08:53am
- ;;5.3;Registration;**624,1015**;Aug 13, 1993;Build 21
- ;
- ;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;
- DGRPE4 ;ALB/GTS - REGISTRATIONS EDITS ; 5/25/05 08:53am
- +1 ;;5.3;Registration;**624,1015**;Aug 13, 1993;Build 21
- +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;
