PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 10/05/22
;
S DIKZK=2
S DIKZ(0)=$G(^PS(53.1,DA,0))
S X=$P($G(DIKZ(0)),U,15)
I X'="" S XX=X,X="PSGAXR" X ^%ZOSF("TEST") I S X=XX D ENNPK^PSGAXR
S X=$P($G(DIKZ(0)),U,5)
I X'="" D
.N DIK,DIV,DIU,DIN
.S DIU=$S($D(^PS(53.1,DA,0)):$P(^(0),"^",6),1:"") I DIU S $P(^(0),"^",6)="" I $O(^DD(53.1,6,1,0)) K DIV S (DIV(0),D0)=DA,DIV="",DIH=53.1,DIG=6 D ^DICR K DIV
S DIKZ(4)=$G(^PS(53.1,DA,4))
S X=$P($G(DIKZ(4)),U,1)
I X'="" S XX=X,X="PSGAXR" X ^%ZOSF("TEST") I S X=XX D ENNACKK^PSGAXR
S DIKZ(2)=$G(^PS(53.1,DA,2))
S X=$P($G(DIKZ(2)),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.I '$D(DIU(0)),$D(PSGS0Y) S DIU=$S($D(^PS(53.1,DA,2)):$P(^(2),"^",5),1:"") I DIU]"" S $P(^(2),"^",5)="" I $O(^DD(53.1,39,1,0)) K DIV S (DIV(0),D0)=DA,DIV="",DIH=53.1,DIG=39 D ^DICR K DIV
S X=$P($G(DIKZ(2)),U,1)
I X'="" D
.N DIK,DIV,DIU,DIN
.I $D(PSGS0XT) S DIU=$S($D(^PS(53.1,DA,2)):$P(^(2),"^",6),1:"") I DIU]"" S $P(^(2),"^",6)="" I $O(^DD(53.1,41,1,0)) K DIV S (DIV(0),D0)=DA,DIV="",DIH=53.1,DIG=41 D ^DICR K DIV
S DIKZ(0)=$G(^PS(53.1,DA,0))
S X=$P($G(DIKZ(0)),U,9)
I X'="" S XX=X,X="PSGAXR" X ^%ZOSF("TEST") I S X=XX D ENSK^PSGAXR
S DIKZ(.1)=$G(^PS(53.1,DA,.1))
S X=$P($G(DIKZ(.1)),U,1)
I X'="" D ENNDK^PSGAXR
S DIKZ(.2)=$G(^PS(53.1,DA,.2))
S X=$P($G(DIKZ(.2)),U,8)
I X'="" K ^PS(53.1,"ACX",$E(X,1,30),DA)
S X=$P($G(DIKZ(0)),U,1)
I X'="" K ^PS(53.1,"B",$E(X,1,30),DA)
CR1 S DIXR=502
K X
S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS"))
S X(1)=$P(DIKZ("DSS"),U,1)
S X(2)=$P(DIKZ(0),U,15)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1),X2(2))=""
. K ^PS(53.1,"AD",$E(X(1),1,20),$E(X(2),1,20),DA)
CR2 S DIXR=808
K X
S DIKZ(0)=$G(^PS(53.1,DA,0))
S X(1)=$P(DIKZ(0),U,15)
S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS"))
S X(2)=$P(DIKZ("DSS"),U,1)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. S:$D(DIKIL) (X2,X2(1),X2(2))=""
. K ^PS(53.1,"CIMO",X(1),X(2),DA)
CR3 K X
END G ^PSGXR32
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGXR31 2024 printed Oct 16, 2024@18:04:20 Page 2
PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 10/05/22
+1 ;
+2 SET DIKZK=2
+3 SET DIKZ(0)=$GET(^PS(53.1,DA,0))
+4 SET X=$PIECE($GET(DIKZ(0)),U,15)
+5 IF X'=""
SET XX=X
SET X="PSGAXR"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=XX
DO ENNPK^PSGAXR
+6 SET X=$PIECE($GET(DIKZ(0)),U,5)
+7 IF X'=""
Begin DoDot:1
+8 NEW DIK,DIV,DIU,DIN
+9 SET DIU=$SELECT($DATA(^PS(53.1,DA,0)):$PIECE(^(0),"^",6),1:"")
IF DIU
SET $PIECE(^(0),"^",6)=""
IF $ORDER(^DD(53.1,6,1,0))
KILL DIV
SET (DIV(0),D0)=DA
SET DIV=""
SET DIH=53.1
SET DIG=6
DO ^DICR
KILL DIV
End DoDot:1
+10 SET DIKZ(4)=$GET(^PS(53.1,DA,4))
+11 SET X=$PIECE($GET(DIKZ(4)),U,1)
+12 IF X'=""
SET XX=X
SET X="PSGAXR"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=XX
DO ENNACKK^PSGAXR
+13 SET DIKZ(2)=$GET(^PS(53.1,DA,2))
+14 SET X=$PIECE($GET(DIKZ(2)),U,1)
+15 IF X'=""
Begin DoDot:1
+16 NEW DIK,DIV,DIU,DIN
+17 IF '$DATA(DIU(0))
IF $DATA(PSGS0Y)
SET DIU=$SELECT($DATA(^PS(53.1,DA,2)):$PIECE(^(2),"^",5),1:"")
IF DIU]""
SET $PIECE(^(2),"^",5)=""
IF $ORDER(^DD(53.1,39,1,0))
KILL DIV
SET (DIV(0),D0)=DA
SET DIV=""
SET DIH=53.1
SET DIG=39
DO ^DICR
KILL DIV
End DoDot:1
+18 SET X=$PIECE($GET(DIKZ(2)),U,1)
+19 IF X'=""
Begin DoDot:1
+20 NEW DIK,DIV,DIU,DIN
+21 IF $DATA(PSGS0XT)
SET DIU=$SELECT($DATA(^PS(53.1,DA,2)):$PIECE(^(2),"^",6),1:"")
IF DIU]""
SET $PIECE(^(2),"^",6)=""
IF $ORDER(^DD(53.1,41,1,0))
KILL DIV
SET (DIV(0),D0)=DA
SET DIV=""
SET DIH=53.1
SET DIG=41
DO ^DICR
KILL DIV
End DoDot:1
+22 SET DIKZ(0)=$GET(^PS(53.1,DA,0))
+23 SET X=$PIECE($GET(DIKZ(0)),U,9)
+24 IF X'=""
SET XX=X
SET X="PSGAXR"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=XX
DO ENSK^PSGAXR
+25 SET DIKZ(.1)=$GET(^PS(53.1,DA,.1))
+26 SET X=$PIECE($GET(DIKZ(.1)),U,1)
+27 IF X'=""
DO ENNDK^PSGAXR
+28 SET DIKZ(.2)=$GET(^PS(53.1,DA,.2))
+29 SET X=$PIECE($GET(DIKZ(.2)),U,8)
+30 IF X'=""
KILL ^PS(53.1,"ACX",$EXTRACT(X,1,30),DA)
+31 SET X=$PIECE($GET(DIKZ(0)),U,1)
+32 IF X'=""
KILL ^PS(53.1,"B",$EXTRACT(X,1,30),DA)
CR1 SET DIXR=502
+1 KILL X
+2 SET DIKZ("DSS")=$GET(^PS(53.1,DA,"DSS"))
+3 SET X(1)=$PIECE(DIKZ("DSS"),U,1)
+4 SET X(2)=$PIECE(DIKZ(0),U,15)
+5 SET X=$GET(X(1))
+6 IF $GET(X(1))]""
IF $GET(X(2))]""
Begin DoDot:1
+7 KILL X1,X2
MERGE X1=X,X2=X
+8 if $DATA(DIKIL)
SET (X2,X2(1),X2(2))=""
+9 KILL ^PS(53.1,"AD",$EXTRACT(X(1),1,20),$EXTRACT(X(2),1,20),DA)
End DoDot:1
CR2 SET DIXR=808
+1 KILL X
+2 SET DIKZ(0)=$GET(^PS(53.1,DA,0))
+3 SET X(1)=$PIECE(DIKZ(0),U,15)
+4 SET DIKZ("DSS")=$GET(^PS(53.1,DA,"DSS"))
+5 SET X(2)=$PIECE(DIKZ("DSS"),U,1)
+6 SET X=$GET(X(1))
+7 IF $GET(X(1))]""
IF $GET(X(2))]""
Begin DoDot:1
+8 KILL X1,X2
MERGE X1=X,X2=X
+9 if $DATA(DIKIL)
SET (X2,X2(1),X2(2))=""
+10 KILL ^PS(53.1,"CIMO",X(1),X(2),DA)
End DoDot:1
CR3 KILL X
END GOTO ^PSGXR32
