PRCNX1.m

PRCNX1 ; COMPILED XREF FOR FILE #413 ; 10/15/04

 ; 

 S DIKZK=2

 S DIKZ(0)=$G(^PRCN(413,DA,0))

 S X=$P(DIKZ(0),U,3)

 I X'="" K ^PRCN(413,"AE",$E(X,1,30),DA)

 S X=$P(DIKZ(0),U,6)

 I X'="" K ^PRCN(413,"AD",$E(X,1,30),DA)

 S X=$P(DIKZ(0),U,7)

 I X'="" K ^PRCN(413,"AC",$E(X,1,30),DA)

 S DIKZ(2)=$G(^PRCN(413,DA,2))

 S X=$P(DIKZ(2),U,14)

 I X'="" D

 .N DIK,DIV,DIU,DIN

 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^PRCN(413,D0,2)):^(2),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" X ^DD(413,30,1,1,2.4)

 S DIKZ(2)=$G(^PRCN(413,DA,2))

 S X=$P(DIKZ(2),U,18)

 I X'="" S SK=1 D XREF^PRCNCMRP K SK

 S DIKZ(6)=$G(^PRCN(413,DA,6))

 S X=$P(DIKZ(6),U,3)

 I X'="" K ^PRCN(413,"E",$E(X,1,30),DA)

 S DIKZ(0)=$G(^PRCN(413,DA,0))

 S X=$P(DIKZ(0),U,1)

 I X'="" K ^PRCN(413,"B",$E(X,1,30),DA)

END G ^PRCNX2

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCNX1   813     printed  Apr 09, 2024@20:59:45                                                                                                                                                                                                       Page 2

PRCNX1    ; COMPILED XREF FOR FILE #413 ; 10/15/04

 +1       ; 

 +2        SET DIKZK=2

 +3        SET DIKZ(0)=$GET(^PRCN(413,DA,0))

 +4        SET X=$PIECE(DIKZ(0),U,3)

 +5        IF X'=""

               KILL ^PRCN(413,"AE",$EXTRACT(X,1,30),DA)

 +6        SET X=$PIECE(DIKZ(0),U,6)

 +7        IF X'=""

               KILL ^PRCN(413,"AD",$EXTRACT(X,1,30),DA)

 +8        SET X=$PIECE(DIKZ(0),U,7)

 +9        IF X'=""

               KILL ^PRCN(413,"AC",$EXTRACT(X,1,30),DA)

 +10       SET DIKZ(2)=$GET(^PRCN(413,DA,2))

 +11       SET X=$PIECE(DIKZ(2),U,14)

 +12       IF X'=""

               Begin DoDot:1

 +13               NEW DIK,DIV,DIU,DIN

 +14               KILL DIV

                   SET DIV=X

                   SET D0=DA

                   SET DIV(0)=D0

                   SET Y(1)=$SELECT($DATA(^PRCN(413,D0,2)):^(2),1:"")

                   SET X=$PIECE(Y(1),U,15)

                   SET X=X

                   SET DIU=X

                   KILL Y

                   SET X=""

                   XECUTE ^DD(413,30,1,1,2.4)

               End DoDot:1

 +15       SET DIKZ(2)=$GET(^PRCN(413,DA,2))

 +16       SET X=$PIECE(DIKZ(2),U,18)

 +17       IF X'=""

               SET SK=1

               DO XREF^PRCNCMRP

               KILL SK

 +18       SET DIKZ(6)=$GET(^PRCN(413,DA,6))

 +19       SET X=$PIECE(DIKZ(6),U,3)

 +20       IF X'=""

               KILL ^PRCN(413,"E",$EXTRACT(X,1,30),DA)

 +21       SET DIKZ(0)=$GET(^PRCN(413,DA,0))

 +22       SET X=$PIECE(DIKZ(0),U,1)

 +23       IF X'=""

               KILL ^PRCN(413,"B",$EXTRACT(X,1,30),DA)

END        GOTO ^PRCNX2