PSSJXR24 ; COMPILED XREF FOR FILE #55.06 ; 08/08/13
;
I X'="" I '$D(DIU(0)) D:$D(PSGAL(69)) KILL^PSGAL5:PSGAL(69)=X K PSGAL
S DIKZ(5)=$G(^PS(55,DA(1),5,DA,5))
S X=$P($G(DIKZ(5)),U,7)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(70)) KILL^PSGAL5:PSGAL(70)=X K PSGAL
S X=$P($G(DIKZ(5)),U,8)
I X'="" D
.N DIK,DIV,DIU,DIN
.I X S DIU=$S($D(^PS(55,DA(1),5,DA,5)):$P(^(5),"^",7),1:""),$P(^(5),"^",7)=DIU+X I $O(^DD(55.06,54,1,0)) K DIV S (DIV(0),D0)=DA(1),(DIV(1),D1)=DA,DIV=DIU+X,DIH=55.06,DIG=54 D ^DICR
S X=$P($G(DIKZ(5)),U,8)
I X'="" ; I '$D(DIU(0)),X S PSGAMSF=0 D ^PSGAMSA
S DIKZ(4)=$G(^PS(55,DA(1),5,DA,4))
S X=$P($G(DIKZ(4)),U,18)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(71)) KILL^PSGAL5:PSGAL(71)=X K PSGAL
S X=$P($G(DIKZ(4)),U,19)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(72)) KILL^PSGAL5:PSGAL(72)=X K PSGAL
S X=$P($G(DIKZ(4)),U,20)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(73)) KILL^PSGAL5:PSGAL(73)=X K PSGAL
S X=$P($G(DIKZ(4)),U,21)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(74)) KILL^PSGAL5:PSGAL(74)=X K PSGAL
S X=$P($G(DIKZ(4)),U,22)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(75)) KILL^PSGAL5:PSGAL(75)=X K PSGAL
S X=$P($G(DIKZ(4)),U,23)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(76)) KILL^PSGAL5:PSGAL(76)=X K PSGAL
S X=$P($G(DIKZ(4)),U,24)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(77)) KILL^PSGAL5:PSGAL(77)=X K PSGAL
S DIKZ(0)=$G(^PS(55,DA(1),5,DA,0))
S X=$P($G(DIKZ(0)),U,20)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(79)) KILL^PSGAL5:PSGAL(79)=X K PSGAL
S X=$P($G(DIKZ(0)),U,20)
I X'="" S ^PS(55,"AUDDD",$E(X,1,30),DA(1),DA)=""
S DIKZ(6.5)=$G(^PS(55,DA(1),5,DA,6.5))
S X=$P($G(DIKZ(6.5)),U,1)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(78)) KILL^PSGAL5:PSGAL(78)=X K PSGAL
S X=$P($G(DIKZ(0)),U,21)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(80)) KILL^PSGAL5:PSGAL(80)=X K PSGAL
S DIKZ(.1)=$G(^PS(55,DA(1),5,DA,.1))
S X=$P($G(DIKZ(.1)),U,1)
I X'="" S ^PS(55,DA(1),5,"C",$E(X,1,30),DA)=""
S X=$P($G(DIKZ(.1)),U,1)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(101)) KILL^PSGAL5:PSGAL(101)=X K PSGAL
S X=$P($G(DIKZ(.1)),U,2)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(102)) KILL^PSGAL5:PSGAL(102)=X K PSGAL
S X=$P($G(DIKZ(0)),U,24)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(103)) KILL^PSGAL5:PSGAL(103)=X K PSGAL
S X=$P($G(DIKZ(0)),U,25)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(104)) KILL^PSGAL5:PSGAL(104)=X K PSGAL
S X=$P($G(DIKZ(0)),U,26)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(105)) KILL^PSGAL5:PSGAL(105)=X K PSGAL
S X=$P($G(DIKZ(.1)),U,3)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(106)) KILL^PSGAL5:PSGAL(106)=X K PSGAL
S X=$P($G(DIKZ(0)),U,27)
I X'="" I '$D(DIU(0)) D:$D(PSGAL(107)) KILL^PSGAL5:PSGAL(107)=X K PSGAL
CR1 S DIXR=431
K X
S DIKZ(.2)=$G(^PS(55,DA(1),5,DA,.2))
S X(1)=$P(DIKZ(.2),U,8)
S X(2)=$P(DIKZ(0),U,21)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. N DIKXARR M DIKXARR=X S DIKCOND=1
. S X=1
. S DIKCOND=$G(X) K X M X=DIKXARR
. Q:'DIKCOND
. S ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"U")=""
CR2 S DIXR=434
K X
S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
S X(1)=$P(DIKZ(2),U,2)
S X(2)=$P(DIKZ(2),U,4)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. N DIKXARR M DIKXARR=X S DIKCOND=1
. S X=$$PATCH^XPDUTL("PXRM*1.5*12")
. S DIKCOND=$G(X) K X M X=DIKXARR
. Q:'DIKCOND
. D SPSPA^PSJXRFS(.X,.DA,"UD")
CR3 S DIXR=452
K X
S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
S X(1)=$P(DIKZ(2),U,4)
S DIKZ(8)=$G(^PS(55,DA(1),5,DA,8))
S X(2)=$P(DIKZ(8),U,1)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. S ^PS(55,"AUDC",$E(X(1),1,20),$E(X(2),1,20),DA(1),DA)=""
CR4 S DIXR=454
K X
S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
S X(1)=$P(DIKZ(2),U,4)
S DIKZ(8)=$G(^PS(55,DA(1),5,DA,8))
S X(2)=$P(DIKZ(8),U,1)
S X=$G(X(1))
I $G(X(1))]"",$G(X(2))]"" D
. K X1,X2 M X1=X,X2=X
. S ^PS(55,DA(1),5,"AUN",X(1),X(2),DA)=""
CR5 K X
G:'$D(DIKLM) A^PSSJXR23 Q:$D(DISET)
END G ^PSSJXR25
PSSJXR24 ; COMPILED XREF FOR FILE #55.06 ; 08/08/13
+1 ;
+2 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(69))
IF PSGAL(69)=X
DO KILL^PSGAL5
KILL PSGAL
+3 SET DIKZ(5)=$GET(^PS(55,DA(1),5,DA,5))
+4 SET X=$PIECE($GET(DIKZ(5)),U,7)
+5 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(70))
IF PSGAL(70)=X
DO KILL^PSGAL5
KILL PSGAL
+6 SET X=$PIECE($GET(DIKZ(5)),U,8)
+7 IF X'=""
Begin DoDot:1
+8 NEW DIK,DIV,DIU,DIN
+9 IF X
SET DIU=$SELECT($DATA(^PS(55,DA(1),5,DA,5)):$PIECE(^(5),"^",7),1:"")
SET $PIECE(^(5),"^",7)=DIU+X
IF $ORDER(^DD(55.06,54,1,0))
KILL DIV
SET (DIV(0),D0)=DA(1)
SET (DIV(1),D1)=DA
SET DIV=DIU+X
SET DIH=55.06
SET DIG=54
DO ^DICR
End DoDot:1
+10 SET X=$PIECE($GET(DIKZ(5)),U,8)
+11 ; I '$D(DIU(0)),X S PSGAMSF=0 D ^PSGAMSA
IF X'=""
+12 SET DIKZ(4)=$GET(^PS(55,DA(1),5,DA,4))
+13 SET X=$PIECE($GET(DIKZ(4)),U,18)
+14 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(71))
IF PSGAL(71)=X
DO KILL^PSGAL5
KILL PSGAL
+15 SET X=$PIECE($GET(DIKZ(4)),U,19)
+16 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(72))
IF PSGAL(72)=X
DO KILL^PSGAL5
KILL PSGAL
+17 SET X=$PIECE($GET(DIKZ(4)),U,20)
+18 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(73))
IF PSGAL(73)=X
DO KILL^PSGAL5
KILL PSGAL
+19 SET X=$PIECE($GET(DIKZ(4)),U,21)
+20 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(74))
IF PSGAL(74)=X
DO KILL^PSGAL5
KILL PSGAL
+21 SET X=$PIECE($GET(DIKZ(4)),U,22)
+22 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(75))
IF PSGAL(75)=X
DO KILL^PSGAL5
KILL PSGAL
+23 SET X=$PIECE($GET(DIKZ(4)),U,23)
+24 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(76))
IF PSGAL(76)=X
DO KILL^PSGAL5
KILL PSGAL
+25 SET X=$PIECE($GET(DIKZ(4)),U,24)
+26 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(77))
IF PSGAL(77)=X
DO KILL^PSGAL5
KILL PSGAL
+27 SET DIKZ(0)=$GET(^PS(55,DA(1),5,DA,0))
+28 SET X=$PIECE($GET(DIKZ(0)),U,20)
+29 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(79))
IF PSGAL(79)=X
DO KILL^PSGAL5
KILL PSGAL
+30 SET X=$PIECE($GET(DIKZ(0)),U,20)
+31 IF X'=""
SET ^PS(55,"AUDDD",$EXTRACT(X,1,30),DA(1),DA)=""
+32 SET DIKZ(6.5)=$GET(^PS(55,DA(1),5,DA,6.5))
+33 SET X=$PIECE($GET(DIKZ(6.5)),U,1)
+34 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(78))
IF PSGAL(78)=X
DO KILL^PSGAL5
KILL PSGAL
+35 SET X=$PIECE($GET(DIKZ(0)),U,21)
+36 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(80))
IF PSGAL(80)=X
DO KILL^PSGAL5
KILL PSGAL
+37 SET DIKZ(.1)=$GET(^PS(55,DA(1),5,DA,.1))
+38 SET X=$PIECE($GET(DIKZ(.1)),U,1)
+39 IF X'=""
SET ^PS(55,DA(1),5,"C",$EXTRACT(X,1,30),DA)=""
+40 SET X=$PIECE($GET(DIKZ(.1)),U,1)
+41 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(101))
IF PSGAL(101)=X
DO KILL^PSGAL5
KILL PSGAL
+42 SET X=$PIECE($GET(DIKZ(.1)),U,2)
+43 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(102))
IF PSGAL(102)=X
DO KILL^PSGAL5
KILL PSGAL
+44 SET X=$PIECE($GET(DIKZ(0)),U,24)
+45 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(103))
IF PSGAL(103)=X
DO KILL^PSGAL5
KILL PSGAL
+46 SET X=$PIECE($GET(DIKZ(0)),U,25)
+47 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(104))
IF PSGAL(104)=X
DO KILL^PSGAL5
KILL PSGAL
+48 SET X=$PIECE($GET(DIKZ(0)),U,26)
+49 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(105))
IF PSGAL(105)=X
DO KILL^PSGAL5
KILL PSGAL
+50 SET X=$PIECE($GET(DIKZ(.1)),U,3)
+51 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(106))
IF PSGAL(106)=X
DO KILL^PSGAL5
KILL PSGAL
+52 SET X=$PIECE($GET(DIKZ(0)),U,27)
+53 IF X'=""
IF '$DATA(DIU(0))
IF $DATA(PSGAL(107))
IF PSGAL(107)=X
DO KILL^PSGAL5
KILL PSGAL
CR1 SET DIXR=431
+1 KILL X
+2 SET DIKZ(.2)=$GET(^PS(55,DA(1),5,DA,.2))
+3 SET X(1)=$PIECE(DIKZ(.2),U,8)
+4 SET X(2)=$PIECE(DIKZ(0),U,21)
+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 NEW DIKXARR
MERGE DIKXARR=X
SET DIKCOND=1
+9 SET X=1
+10 SET DIKCOND=$GET(X)
KILL X
MERGE X=DIKXARR
+11 IF 'DIKCOND
QUIT
+12 SET ^PS(55,"ACX",$EXTRACT(X(1),1,30),$EXTRACT(X(2),1,30),DA_"U")=""
End DoDot:1
CR2 SET DIXR=434
+1 KILL X
+2 SET DIKZ(2)=$GET(^PS(55,DA(1),5,DA,2))
+3 SET X(1)=$PIECE(DIKZ(2),U,2)
+4 SET X(2)=$PIECE(DIKZ(2),U,4)
+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 NEW DIKXARR
MERGE DIKXARR=X
SET DIKCOND=1
+9 SET X=$$PATCH^XPDUTL("PXRM*1.5*12")
+10 SET DIKCOND=$GET(X)
KILL X
MERGE X=DIKXARR
+11 IF 'DIKCOND
QUIT
+12 DO SPSPA^PSJXRFS(.X,.DA,"UD")
End DoDot:1
CR3 SET DIXR=452
+1 KILL X
+2 SET DIKZ(2)=$GET(^PS(55,DA(1),5,DA,2))
+3 SET X(1)=$PIECE(DIKZ(2),U,4)
+4 SET DIKZ(8)=$GET(^PS(55,DA(1),5,DA,8))
+5 SET X(2)=$PIECE(DIKZ(8),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 SET ^PS(55,"AUDC",$EXTRACT(X(1),1,20),$EXTRACT(X(2),1,20),DA(1),DA)=""
End DoDot:1
CR4 SET DIXR=454
+1 KILL X
+2 SET DIKZ(2)=$GET(^PS(55,DA(1),5,DA,2))
+3 SET X(1)=$PIECE(DIKZ(2),U,4)
+4 SET DIKZ(8)=$GET(^PS(55,DA(1),5,DA,8))
+5 SET X(2)=$PIECE(DIKZ(8),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 SET ^PS(55,DA(1),5,"AUN",X(1),X(2),DA)=""
End DoDot:1
CR5 KILL X
+1 IF '$DATA(DIKLM)
GOTO A^PSSJXR23
IF $DATA(DISET)
QUIT
END GOTO ^PSSJXR25
