- 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 Feb 19, 2025@00:00:44 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