- PSJXR515 ; COMPILED XREF FOR FILE #55.06 ; 10/28/97
- ;
- I X'="" S ^PS(55,DA(1),5,"AUS",+X,DA)="" I $P($G(^PS(55,DA(1),5,DA,0)),"^",7)]"" S ^PS(55,DA(1),5,"AU",$P(^(0),"^",7),+X,DA)=""
- S X=$P(DIKZ(2),U,4)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(53))#2 KILL^PSGAL5:PSGAL(53)=X K PSGAL
- S X=$P(DIKZ(2),U,4)
- I X'="" S ^PS(55,"AUD",$E(X,1,30),DA(1),DA)=""
- S X=$P(DIKZ(5),U,4)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(61))#2 KILL^PSGAL5:PSGAL(61)=X K PSGAL
- S X=$P(DIKZ(5),U,3)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(54))#2 KILL^PSGAL5:PSGAL(54)=X K PSGAL
- S X=$P(DIKZ(5),U,5)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .I X S DIU=$S($D(^PS(55,DA(1),5,DA,5)):$P(^(5),"^",4),1:""),$P(^(5),"^",4)=DIU+X I $O(^DD(55.06,35,1,0)) K DIV S (DIV(0),D0)=DA(1),(DIV(1),D1)=DA,DIV=DIU+X,DIH=55.06,DIG=35 D ^DICR
- S X=$P(DIKZ(5),U,5)
- I X'="" ; I X S PSGAMSF=2 D ^PSGAMSA
- S X=$P(DIKZ(2),U,5)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(56))#2 KILL^PSGAL5:PSGAL(56)=X K PSGAL
- S X=$P(DIKZ(2),U,5)
- I X'="" I $P($G(^PS(55,DA(1),5,DA,2)),"^")["@" S $P(^(2),"^")=$P($P(^(2),"^"),"@")_"@"_X
- S X=$P(DIKZ(2),U,6)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(57))#2 KILL^PSGAL5:PSGAL(57)=X K PSGAL
- S X=$P(DIKZ(4),U,15)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(58)) KILL^PSGAL5:PSGAL(58)=X K PSGAL
- S X=$P(DIKZ(4),U,16)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(59))#2 KILL^PSGAL5:PSGAL(59)=X K PSGAL
- S X=$P(DIKZ(4),U,17)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(60))#2 KILL^PSGAL5:PSGAL(60)=X K PSGAL
- S X=$P(DIKZ(4),U,12)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(63)) KILL^PSGAL5:PSGAL(63)=X K PSGAL
- S X=$P(DIKZ(4),U,13)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(64)) KILL^PSGAL5:PSGAL(64)=X K PSGAL
- S X=$P(DIKZ(4),U,14)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(65)) KILL^PSGAL5:PSGAL(65)=X K PSGAL
- S X=$P(DIKZ(4),U,11)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(62))#2 KILL^PSGAL5:PSGAL(62)=X K PSGAL
- S X=$P(DIKZ(4),U,9)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(66)) KILL^PSGAL5:PSGAL(66)=X K PSGAL
- S X=$P(DIKZ(4),U,10)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(67)) KILL^PSGAL5:PSGAL(67)=X K PSGAL
- S DIKZ(7)=$G(^PS(55,DA(1),5,DA,7))
- S X=$P(DIKZ(7),U,1)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(68)) KILL^PSGAL5:PSGAL(68)=X K PSGAL
- S X=$P(DIKZ(7),U,2)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(69)) KILL^PSGAL5:PSGAL(69)=X K PSGAL
- S X=$P(DIKZ(5),U,7)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(70)) KILL^PSGAL5:PSGAL(70)=X K PSGAL
- S X=$P(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(DIKZ(5),U,8)
- I X'="" ; I '$D(DIU(0)),X S PSGAMSF=0 D ^PSGAMSA
- S X=$P(DIKZ(4),U,18)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(71)) KILL^PSGAL5:PSGAL(71)=X K PSGAL
- S X=$P(DIKZ(4),U,19)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(72)) KILL^PSGAL5:PSGAL(72)=X K PSGAL
- S X=$P(DIKZ(4),U,20)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(73)) KILL^PSGAL5:PSGAL(73)=X K PSGAL
- S X=$P(DIKZ(4),U,21)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(74)) KILL^PSGAL5:PSGAL(74)=X K PSGAL
- S X=$P(DIKZ(4),U,22)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(75)) KILL^PSGAL5:PSGAL(75)=X K PSGAL
- S X=$P(DIKZ(4),U,23)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(76)) KILL^PSGAL5:PSGAL(76)=X K PSGAL
- S X=$P(DIKZ(4),U,24)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(77)) KILL^PSGAL5:PSGAL(77)=X K PSGAL
- S X=$P(DIKZ(0),U,20)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(79)) KILL^PSGAL5:PSGAL(79)=X K PSGAL
- S X=$P(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(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(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(DIKZ(.1),U,1)
- I X'="" S ^PS(55,DA(1),5,"C",$E(X,1,30),DA)=""
- S X=$P(DIKZ(.1),U,1)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(101)) KILL^PSGAL5:PSGAL(101)=X K PSGAL
- S X=$P(DIKZ(.1),U,2)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(102)) KILL^PSGAL5:PSGAL(102)=X K PSGAL
- S X=$P(DIKZ(0),U,24)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(103)) KILL^PSGAL5:PSGAL(103)=X K PSGAL
- S X=$P(DIKZ(0),U,25)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(104)) KILL^PSGAL5:PSGAL(104)=X K PSGAL
- S X=$P(DIKZ(0),U,26)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(105)) KILL^PSGAL5:PSGAL(105)=X K PSGAL
- S X=$P(DIKZ(.1),U,3)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(106)) KILL^PSGAL5:PSGAL(106)=X K PSGAL
- S X=$P(DIKZ(0),U,27)
- I X'="" I '$D(DIU(0)) D:$D(PSGAL(107)) KILL^PSGAL5:PSGAL(107)=X K PSGAL
- G:'$D(DIKLM) A^PSJXR514 Q:$D(DISET)
- END G ^PSJXR516
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJXR515 4552 printed Feb 18, 2025@23:35:46 Page 2
- PSJXR515 ; COMPILED XREF FOR FILE #55.06 ; 10/28/97
- +1 ;
- +2 IF X'=""
- SET ^PS(55,DA(1),5,"AUS",+X,DA)=""
- IF $PIECE($GET(^PS(55,DA(1),5,DA,0)),"^",7)]""
- SET ^PS(55,DA(1),5,"AU",$PIECE(^(0),"^",7),+X,DA)=""
- +3 SET X=$PIECE(DIKZ(2),U,4)
- +4 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(53))#2
- if PSGAL(53)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +5 SET X=$PIECE(DIKZ(2),U,4)
- +6 IF X'=""
- SET ^PS(55,"AUD",$EXTRACT(X,1,30),DA(1),DA)=""
- +7 SET X=$PIECE(DIKZ(5),U,4)
- +8 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(61))#2
- if PSGAL(61)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +9 SET X=$PIECE(DIKZ(5),U,3)
- +10 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(54))#2
- if PSGAL(54)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +11 SET X=$PIECE(DIKZ(5),U,5)
- +12 IF X'=""
- Begin DoDot:1
- +13 NEW DIK,DIV,DIU,DIN
- +14 IF X
- SET DIU=$SELECT($DATA(^PS(55,DA(1),5,DA,5)):$PIECE(^(5),"^",4),1:"")
- SET $PIECE(^(5),"^",4)=DIU+X
- IF $ORDER(^DD(55.06,35,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=35
- DO ^DICR
- End DoDot:1
- +15 SET X=$PIECE(DIKZ(5),U,5)
- +16 ; I X S PSGAMSF=2 D ^PSGAMSA
- IF X'=""
- +17 SET X=$PIECE(DIKZ(2),U,5)
- +18 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(56))#2
- if PSGAL(56)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +19 SET X=$PIECE(DIKZ(2),U,5)
- +20 IF X'=""
- IF $PIECE($GET(^PS(55,DA(1),5,DA,2)),"^")["@"
- SET $PIECE(^(2),"^")=$PIECE($PIECE(^(2),"^"),"@")_"@"_X
- +21 SET X=$PIECE(DIKZ(2),U,6)
- +22 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(57))#2
- if PSGAL(57)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +23 SET X=$PIECE(DIKZ(4),U,15)
- +24 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(58))
- if PSGAL(58)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +25 SET X=$PIECE(DIKZ(4),U,16)
- +26 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(59))#2
- if PSGAL(59)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +27 SET X=$PIECE(DIKZ(4),U,17)
- +28 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(60))#2
- if PSGAL(60)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +29 SET X=$PIECE(DIKZ(4),U,12)
- +30 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(63))
- if PSGAL(63)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +31 SET X=$PIECE(DIKZ(4),U,13)
- +32 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(64))
- if PSGAL(64)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +33 SET X=$PIECE(DIKZ(4),U,14)
- +34 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(65))
- if PSGAL(65)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +35 SET X=$PIECE(DIKZ(4),U,11)
- +36 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(62))#2
- if PSGAL(62)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +37 SET X=$PIECE(DIKZ(4),U,9)
- +38 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(66))
- if PSGAL(66)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +39 SET X=$PIECE(DIKZ(4),U,10)
- +40 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(67))
- if PSGAL(67)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +41 SET DIKZ(7)=$GET(^PS(55,DA(1),5,DA,7))
- +42 SET X=$PIECE(DIKZ(7),U,1)
- +43 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(68))
- if PSGAL(68)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +44 SET X=$PIECE(DIKZ(7),U,2)
- +45 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(69))
- if PSGAL(69)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +46 SET X=$PIECE(DIKZ(5),U,7)
- +47 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(70))
- if PSGAL(70)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +48 SET X=$PIECE(DIKZ(5),U,8)
- +49 IF X'=""
- Begin DoDot:1
- +50 NEW DIK,DIV,DIU,DIN
- +51 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
- +52 SET X=$PIECE(DIKZ(5),U,8)
- +53 ; I '$D(DIU(0)),X S PSGAMSF=0 D ^PSGAMSA
- IF X'=""
- +54 SET X=$PIECE(DIKZ(4),U,18)
- +55 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(71))
- if PSGAL(71)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +56 SET X=$PIECE(DIKZ(4),U,19)
- +57 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(72))
- if PSGAL(72)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +58 SET X=$PIECE(DIKZ(4),U,20)
- +59 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(73))
- if PSGAL(73)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +60 SET X=$PIECE(DIKZ(4),U,21)
- +61 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(74))
- if PSGAL(74)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +62 SET X=$PIECE(DIKZ(4),U,22)
- +63 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(75))
- if PSGAL(75)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +64 SET X=$PIECE(DIKZ(4),U,23)
- +65 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(76))
- if PSGAL(76)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +66 SET X=$PIECE(DIKZ(4),U,24)
- +67 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(77))
- if PSGAL(77)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +68 SET X=$PIECE(DIKZ(0),U,20)
- +69 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(79))
- if PSGAL(79)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +70 SET X=$PIECE(DIKZ(0),U,20)
- +71 IF X'=""
- SET ^PS(55,"AUDDD",$EXTRACT(X,1,30),DA(1),DA)=""
- +72 SET DIKZ(6.5)=$GET(^PS(55,DA(1),5,DA,6.5))
- +73 SET X=$PIECE(DIKZ(6.5),U,1)
- +74 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(78))
- if PSGAL(78)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +75 SET X=$PIECE(DIKZ(0),U,21)
- +76 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(80))
- if PSGAL(80)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +77 SET DIKZ(.1)=$GET(^PS(55,DA(1),5,DA,.1))
- +78 SET X=$PIECE(DIKZ(.1),U,1)
- +79 IF X'=""
- SET ^PS(55,DA(1),5,"C",$EXTRACT(X,1,30),DA)=""
- +80 SET X=$PIECE(DIKZ(.1),U,1)
- +81 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(101))
- if PSGAL(101)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +82 SET X=$PIECE(DIKZ(.1),U,2)
- +83 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(102))
- if PSGAL(102)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +84 SET X=$PIECE(DIKZ(0),U,24)
- +85 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(103))
- if PSGAL(103)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +86 SET X=$PIECE(DIKZ(0),U,25)
- +87 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(104))
- if PSGAL(104)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +88 SET X=$PIECE(DIKZ(0),U,26)
- +89 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(105))
- if PSGAL(105)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +90 SET X=$PIECE(DIKZ(.1),U,3)
- +91 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(106))
- if PSGAL(106)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +92 SET X=$PIECE(DIKZ(0),U,27)
- +93 IF X'=""
- IF '$DATA(DIU(0))
- if $DATA(PSGAL(107))
- if PSGAL(107)=X
- DO KILL^PSGAL5
- KILL PSGAL
- +94 if '$DATA(DIKLM)
- GOTO A^PSJXR514
- if $DATA(DISET)
- QUIT
- END GOTO ^PSJXR516
