PSSVX61 ; COMPILED XREF FOR FILE #52.6 ; 11/28/17
;
S DIKZK=2
S DIKZ(0)=$G(^PS(52.6,DA,0))
S X=$P($G(DIKZ(0)),U,2)
I X'="" K ^PS(52.6,"AC",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,2)
I X'="" I '$D(^PS(52.7,"AC",X)) S XX=$O(^PS(52.6,"AC",X,0)) S:XX=DA XX=$O(^(XX)) I XX,$P($G(^PSDRUG(X,2)),"^",3)["I" S PSIUDA=X,PSIUX="I" D END^PSSGIU
S X=$P($G(DIKZ(0)),U,2)
I X'="" D
.N DIK,DIV,DIU,DIN
.S DIU=$P($G(^PS(52.6,DA,0)),U,12) I DIU]"" S $P(^(0),U,12)="" I $O(^DD(52.6,16,1,0)) K DIV S (DIV,X)="",(D0,DIV(0))=DA,DIH=52.6,DIG=16 D ^DICR
S X=$P($G(DIKZ(0)),U,2)
I X'="" D K526^PSSPOID1
S DIKZ("I")=$G(^PS(52.6,DA,"I"))
S X=$P($G(DIKZ("I")),U,1)
I X'="" X ^DD(52.6,12,1,1,2)
S DIKZ(0)=$G(^PS(52.6,DA,0))
S X=$P($G(DIKZ(0)),U,11)
I X'="" K ^PS(52.6,"AOI",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,12)
I X'="" K ^PS(52.6,"APD",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,13)
I X'="" X ^DD(52.6,17,1,1,2)
S DIKZ(0)=$G(^PS(52.6,DA,0))
S X=$P($G(DIKZ(0)),U,1)
I X'="" K ^PS(52.6,"B",$E(X,1,30),DA)
END G ^PSSVX62
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSVX61 1036 printed Dec 13, 2024@02:34:42 Page 2
PSSVX61 ; COMPILED XREF FOR FILE #52.6 ; 11/28/17
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ(0)=$GET(^PS(52.6,DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,2)
+5 IF X'=""
KILL ^PS(52.6,"AC",$EXTRACT(X,1,30),DA)
+6 SET X=$PIECE($GET(DIKZ(0)),U,2)
+7 IF X'=""
IF '$DATA(^PS(52.7,"AC",X))
SET XX=$ORDER(^PS(52.6,"AC",X,0))
if XX=DA
SET XX=$ORDER(^(XX))
IF XX
IF $PIECE($GET(^PSDRUG(X,2)),"^",3)["I"
SET PSIUDA=X
SET PSIUX="I"
DO END^PSSGIU
+8 SET X=$PIECE($GET(DIKZ(0)),U,2)
+9 IF X'=""
Begin DoDot:1
+10 NEW DIK,DIV,DIU,DIN
+11 SET DIU=$PIECE($GET(^PS(52.6,DA,0)),U,12)
IF DIU]""
SET $PIECE(^(0),U,12)=""
IF $ORDER(^DD(52.6,16,1,0))
KILL DIV
SET (DIV,X)=""
SET (D0,DIV(0))=DA
SET DIH=52.6
SET DIG=16
DO ^DICR
End DoDot:1
+12 SET X=$PIECE($GET(DIKZ(0)),U,2)
+13 IF X'=""
DO K526^PSSPOID1
+14 SET DIKZ("I")=$GET(^PS(52.6,DA,"I"))
+15 SET X=$PIECE($GET(DIKZ("I")),U,1)
+16 IF X'=""
XECUTE ^DD(52.6,12,1,1,2)
+17 SET DIKZ(0)=$GET(^PS(52.6,DA,0))
+18 SET X=$PIECE($GET(DIKZ(0)),U,11)
+19 IF X'=""
KILL ^PS(52.6,"AOI",$EXTRACT(X,1,30),DA)
+20 SET X=$PIECE($GET(DIKZ(0)),U,12)
+21 IF X'=""
KILL ^PS(52.6,"APD",$EXTRACT(X,1,30),DA)
+22 SET X=$PIECE($GET(DIKZ(0)),U,13)
+23 IF X'=""
XECUTE ^DD(52.6,17,1,1,2)
+24 SET DIKZ(0)=$GET(^PS(52.6,DA,0))
+25 SET X=$PIECE($GET(DIKZ(0)),U,1)
+26 IF X'=""
KILL ^PS(52.6,"B",$EXTRACT(X,1,30),DA)
END GOTO ^PSSVX62
