DGPTXX13 ; COMPILED XREF FOR FILE #45.0535 ; 02/01/23
;
S DA=0
A1 ;
I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
0 ;
A S DA=$O(^DGPT(DA(1),535,DA)) I DA'>0 S DA=0 G END
1 ;
S DIKZ(0)=$G(^DGPT(DA(1),535,DA,0))
S X=$P($G(DIKZ(0)),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGPT(D0,535,D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y X ^DD(45.0535,2,1,1,1.1) X ^DD(45.0535,2,1,1,1.4)
S DIKZ(0)=$G(^DGPT(DA(1),535,DA,0))
S X=$P($G(DIKZ(0)),U,7)
I X'="" S ^DGPT(DA(1),535,"ADC",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(0)),U,10)
I X'="" S ^DGPT(DA(1),535,"AM",$E(X,1,30),DA)=""
G:'$D(DIKLM) A Q:$D(DISET)
END G ^DGPTXX14
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTXX13 704 printed Oct 16, 2024@18:54:55 Page 2
DGPTXX13 ; COMPILED XREF FOR FILE #45.0535 ; 02/01/23
+1 ;
+2 SET DA=0
A1 ;
+1 IF $DATA(DISET)
KILL DIKLM
if DIKM1=1
SET DIKLM=1
GOTO @DIKM1
0 ;
A SET DA=$ORDER(^DGPT(DA(1),535,DA))
IF DA'>0
SET DA=0
GOTO END
1 ;
+1 SET DIKZ(0)=$GET(^DGPT(DA(1),535,DA,0))
+2 SET X=$PIECE($GET(DIKZ(0)),U,2)
+3 IF X'=""
Begin DoDot:1
+4 NEW DIK,DIV,DIU,DIN
+5 KILL DIV
SET DIV=X
SET D0=DA(1)
SET DIV(0)=D0
SET D1=DA
SET DIV(1)=D1
SET Y(1)=$SELECT($DATA(^DGPT(D0,535,D1,0)):^(0),1:"")
SET X=$PIECE(Y(1),U,16)
SET X=X
SET DIU=X
KILL Y
XECUTE ^DD(45.0535,2,1,1,1.1)
XECUTE ^DD(45.0535,2,1,1,1.4)
End DoDot:1
+6 SET DIKZ(0)=$GET(^DGPT(DA(1),535,DA,0))
+7 SET X=$PIECE($GET(DIKZ(0)),U,7)
+8 IF X'=""
SET ^DGPT(DA(1),535,"ADC",$EXTRACT(X,1,30),DA)=""
+9 SET X=$PIECE($GET(DIKZ(0)),U,10)
+10 IF X'=""
SET ^DGPT(DA(1),535,"AM",$EXTRACT(X,1,30),DA)=""
+11 if '$DATA(DIKLM)
GOTO A
if $DATA(DISET)
QUIT
END GOTO ^DGPTXX14
