- XUCT032 ; COMPILED XREF FOR FILE #3.081 ; 02/11/20
- ;
- S DIKZK=1
- S DIKZ(0)=$G(^XUSEC(0,DA,0))
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" S ^XUSEC(0,"CUR",$E(X,1,30),DA)=""
- S X=$P($G(DIKZ(0)),U,4)
- I X'="" K ^XUSEC(0,"CUR",+^XUSEC(0,DA,0),DA)
- S X=$P($G(DIKZ(0)),U,4)
- I X'="" N %,Y S %=^XUSEC(0,DA,0) K:$L($P(%,U,11)) ^XUSEC(0,"AS1",$P($P(%,U,11),":"),DA) K:$L($P(%,U,12)) ^XUSEC(0,"AS2",$P($P(%,U,12),":"),DA) S Y=$G(^XUSEC(0,DA,1)) K:$L($P(Y,U)) ^XUSEC(0,"AS4",$P(Y,U),DA)
- S X=$P($G(DIKZ(0)),U,4)
- I X'="" N %,Y S %=^XUSEC(0,DA,0) I $L($P(%,U,11)) K ^XUSEC(0,"AS3",$P(%,U),$P($P(%,U,11),":"),DA) S Y=$G(^XUSEC(0,DA,1)) K:$L($P(Y,U)) ^XUSEC(0,"AS5",$P(%,U),$P(Y,U),DA)
- S X=$P($G(DIKZ(0)),U,7)
- I X'="" S ^XUSEC(0,"ALDEV",X)=+^XUSEC(0,DA,0)
- S X=$P($G(DIKZ(0)),U,11)
- I X'="" S:'$P(^XUSEC(0,DA,0),U,4) ^XUSEC(0,"AS1",$P(X,":"),DA)=""
- S X=$P($G(DIKZ(0)),U,11)
- I X'="" N % S %=^XUSEC(0,DA,0) I '$P(%,U,4) S ^XUSEC(0,"AS3",$P(%,U),$P(X,":"),DA)=""
- S X=$P($G(DIKZ(0)),U,12)
- I X'="" S:'$P(^XUSEC(0,DA,0),U,4) ^XUSEC(0,"AS2",$P(X,":"),DA)=""
- S DIKZ(1)=$G(^XUSEC(0,DA,1))
- S X=$P($G(DIKZ(1)),U,1)
- I X'="" S:'$P(^XUSEC(0,DA,0),U,4) ^XUSEC(0,"AS4",X,DA)=""
- S X=$P($G(DIKZ(1)),U,1)
- I X'="" N % S %=^XUSEC(0,DA,0) I '$P(%,U,4) S ^XUSEC(0,"AS5",$P(%,U),X,DA)=""
- END Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUCT032 1286 printed Mar 13, 2025@21:14:09 Page 2
- XUCT032 ; COMPILED XREF FOR FILE #3.081 ; 02/11/20
- +1 ;
- +2 SET DIKZK=1
- +3 SET DIKZ(0)=$GET(^XUSEC(0,DA,0))
- +4 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +5 IF X'=""
- SET ^XUSEC(0,"CUR",$EXTRACT(X,1,30),DA)=""
- +6 SET X=$PIECE($GET(DIKZ(0)),U,4)
- +7 IF X'=""
- KILL ^XUSEC(0,"CUR",+^XUSEC(0,DA,0),DA)
- +8 SET X=$PIECE($GET(DIKZ(0)),U,4)
- +9 IF X'=""
- NEW %,Y
- SET %=^XUSEC(0,DA,0)
- if $LENGTH($PIECE(%,U,11))
- KILL ^XUSEC(0,"AS1",$PIECE($PIECE(%,U,11),":"),DA)
- if $LENGTH($PIECE(%,U,12))
- KILL ^XUSEC(0,"AS2",$PIECE($PIECE(%,U,12),":"),DA)
- SET Y=$GET(^XUSEC(0,DA,1))
- if $LENGTH($PIECE(Y,U))
- KILL ^XUSEC(0,"AS4",$PIECE(Y,U),DA)
- +10 SET X=$PIECE($GET(DIKZ(0)),U,4)
- +11 IF X'=""
- NEW %,Y
- SET %=^XUSEC(0,DA,0)
- IF $LENGTH($PIECE(%,U,11))
- KILL ^XUSEC(0,"AS3",$PIECE(%,U),$PIECE($PIECE(%,U,11),":"),DA)
- SET Y=$GET(^XUSEC(0,DA,1))
- if $LENGTH($PIECE(Y,U))
- KILL ^XUSEC(0,"AS5",$PIECE(%,U),$PIECE(Y,U),DA)
- +12 SET X=$PIECE($GET(DIKZ(0)),U,7)
- +13 IF X'=""
- SET ^XUSEC(0,"ALDEV",X)=+^XUSEC(0,DA,0)
- +14 SET X=$PIECE($GET(DIKZ(0)),U,11)
- +15 IF X'=""
- if '$PIECE(^XUSEC(0,DA,0),U,4)
- SET ^XUSEC(0,"AS1",$PIECE(X,":"),DA)=""
- +16 SET X=$PIECE($GET(DIKZ(0)),U,11)
- +17 IF X'=""
- NEW %
- SET %=^XUSEC(0,DA,0)
- IF '$PIECE(%,U,4)
- SET ^XUSEC(0,"AS3",$PIECE(%,U),$PIECE(X,":"),DA)=""
- +18 SET X=$PIECE($GET(DIKZ(0)),U,12)
- +19 IF X'=""
- if '$PIECE(^XUSEC(0,DA,0),U,4)
- SET ^XUSEC(0,"AS2",$PIECE(X,":"),DA)=""
- +20 SET DIKZ(1)=$GET(^XUSEC(0,DA,1))
- +21 SET X=$PIECE($GET(DIKZ(1)),U,1)
- +22 IF X'=""
- if '$PIECE(^XUSEC(0,DA,0),U,4)
- SET ^XUSEC(0,"AS4",X,DA)=""
- +23 SET X=$PIECE($GET(DIKZ(1)),U,1)
- +24 IF X'=""
- NEW %
- SET %=^XUSEC(0,DA,0)
- IF '$PIECE(%,U,4)
- SET ^XUSEC(0,"AS5",$PIECE(%,U),X,DA)=""
- END QUIT
