PSOPOST3 ;BIR/SAB-index AD cross reference on login date field ;07/29/96
;;7.0;OUTPATIENT PHARMACY;**7,15,25,30,77**;DEC 1997
;
;Reference to ^DD(55,0,"P") and ^DD(55,0,"PS") is supported by IA #2752
;Reference to setting ^DD(52,0,"ID",6) supported by DBIA #2852
;Reference to DIU2 supported by DBIA #10014
;
K ^PS(52.41,"AD")
D BMES^XPDUTL("Indexing 'AD' cross reference...")
F PAT=0:0 S PAT=$O(^PS(52.41,"AOR",PAT)) Q:'PAT F INST=0:0 S INST=$O(^PS(52.41,"AOR",PAT,INST)) Q:'INST D
.F DA=0:0 S DA=$O(^PS(52.41,"AOR",PAT,INST,DA)) Q:'DA D
..I '$P(^PS(52.41,DA,0),"^",12) D NOW^%DTC S $P(^PS(52.41,DA,0),"^",12)=%
..S DIK="^PS(52.41,",DIK(1)=15 D EN1^DIK W "."
K PAT,INST,DA,DIK,DIC,X,Y,%,%H,%I
Q
SUS ;Deleting invalid "AQ" cross references
; Patch PSO*7*15 post init
D BMES^XPDUTL("Indexing 'AQ' cross reference...")
N PSOD,PSOP,PSOIN
F PSOD=0:0 S PSOD=$O(^PS(52.5,"AQ",PSOD)) Q:'PSOD F PSOP=0:0 S PSOP=$O(^PS(52.5,"AQ",PSOD,PSOP)) Q:'PSOP F PSOIN=0:0 S PSOIN=$O(^PS(52.5,"AQ",PSOD,PSOP,PSOIN)) Q:'PSOIN D
.I PSOD'=$P($G(^PS(52.5,PSOIN,0)),"^",2) K ^PS(52.5,"AQ",PSOD,PSOP,PSOIN)
MW ;Update routing field in Pending File
D BMES^XPDUTL("Updating routing field...")
N PAT,INST,PIEN,NODE,RELIN,PSOINZ
F PAT=0:0 S PAT=$O(^PS(52.41,"AOR",PAT)) Q:'PAT F INST=0:0 S INST=$O(^PS(52.41,"AOR",PAT,INST)) Q:'INST F PIEN=0:0 S PIEN=$O(^PS(52.41,"AOR",PAT,INST,PIEN)) Q:'PIEN S NODE=$G(^PS(52.41,PIEN,0)) I $P(NODE,"^",2),$P(NODE,"^",17)="" D
.S $P(^PS(52.41,PIEN,0),"^",17)="M"
.S ^PS(52.41,"AC",$P(NODE,"^",2),"M",PIEN)=""
;Updating Institution field
D BMES^XPDUTL("Updating Institution field...")
F PSOINZ=0:0 S PSOINZ=$O(^PS(59,PSOINZ)) Q:'PSOINZ S RELIN=$P($G(^PS(59,PSOINZ,"INI")),"^") I RELIN D
.I $O(^PS(59,PSOINZ,"INI1",0)) Q
.S ^PS(59,PSOINZ,"INI1",0)="^59.08P^1^1"
.S ^PS(59,PSOINZ,"INI1",1,0)=RELIN
.S ^PS(59,PSOINZ,"INI1","B",RELIN,1)=""
D BMES^XPDUTL("Indexing ACL cross reference...")
N PSODA,PSOPT,PSOPIN,PSONODE
F PSOPT=0:0 S PSOPT=$O(^PS(52.41,"AOR",PSOPT)) Q:'PSOPT F PSOPIN=0:0 S PSOPIN=$O(^PS(52.41,"AOR",PSOPT,PSOPIN)) Q:'PSOPIN F PSODA=0:0 S PSODA=$O(^PS(52.41,"AOR",PSOPT,PSOPIN,PSODA)) Q:'PSODA D
.S PSONODE=$G(^PS(52.41,PSODA,0))
.I $P(PSONODE,"^",3)=""!($P(PSONODE,"^",12)="")!($P(PSONODE,"^",13)="")!($P(PSONODE,"^",2)="") Q
.I $P(PSONODE,"^",3)'="NW",$P(PSONODE,"^",3)'="RNW",$P(PSONODE,"^",3)'="RF" Q
.S ^PS(52.41,"ACL",+$P(PSONODE,"^",13),+$P(PSONODE,"^",12),PSODA)=""
Q
IDNODE ; resets ^DD(52,0,"ID",6) node PSO*7*25
;
D BMES^XPDUTL("Resetting DD(52,0,""ID"",6) Node...")
S ^DD(52,0,"ID",6)="W:$D(^(0)) "" ""_$S($D(^PSDRUG(+$P(^(0),U,6),0))#2:$P(^(0),U,1),1:"""")_$E(^PSRX(+Y,0),0)_$S($P($G(^PSRX(+Y,""STA"")),U)=13:"" ***MARKED FOR DELETION***"",1:"""")"
K ^DD(55,0,"P"),^DD(55,0,"PS")
Q
PEND ;Delete invalid Renewal cross references
D BMES^XPDUTL("Updating 'AQ' cross reference...")
N PSOPN,PSOPNI
F PSOPN=0:0 S PSOPN=$O(^PS(52.41,"AQ",PSOPN)) Q:'PSOPN F PSOPNI=0:0 S PSOPNI=$O(^PS(52.41,"AQ",PSOPN,PSOPNI)) Q:'PSOPNI I $P($G(^PS(52.41,PSOPNI,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") K ^PS(52.41,"AQ",PSOPN,PSOPNI)
Q
SUBF ;hanging sub-file 59.30001 removal
S DIU=59.30001,DIU(0)="S" D:$D(^DD(DIU)) EN^DIU2 K DIU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPOST3 3260 printed Sep 23, 2025@20:09:18 Page 2
PSOPOST3 ;BIR/SAB-index AD cross reference on login date field ;07/29/96
+1 ;;7.0;OUTPATIENT PHARMACY;**7,15,25,30,77**;DEC 1997
+2 ;
+3 ;Reference to ^DD(55,0,"P") and ^DD(55,0,"PS") is supported by IA #2752
+4 ;Reference to setting ^DD(52,0,"ID",6) supported by DBIA #2852
+5 ;Reference to DIU2 supported by DBIA #10014
+6 ;
+7 KILL ^PS(52.41,"AD")
+8 DO BMES^XPDUTL("Indexing 'AD' cross reference...")
+9 FOR PAT=0:0
SET PAT=$ORDER(^PS(52.41,"AOR",PAT))
if 'PAT
QUIT
FOR INST=0:0
SET INST=$ORDER(^PS(52.41,"AOR",PAT,INST))
if 'INST
QUIT
Begin DoDot:1
+10 FOR DA=0:0
SET DA=$ORDER(^PS(52.41,"AOR",PAT,INST,DA))
if 'DA
QUIT
Begin DoDot:2
+11 IF '$PIECE(^PS(52.41,DA,0),"^",12)
DO NOW^%DTC
SET $PIECE(^PS(52.41,DA,0),"^",12)=%
+12 SET DIK="^PS(52.41,"
SET DIK(1)=15
DO EN1^DIK
WRITE "."
End DoDot:2
End DoDot:1
+13 KILL PAT,INST,DA,DIK,DIC,X,Y,%,%H,%I
+14 QUIT
SUS ;Deleting invalid "AQ" cross references
+1 ; Patch PSO*7*15 post init
+2 DO BMES^XPDUTL("Indexing 'AQ' cross reference...")
+3 NEW PSOD,PSOP,PSOIN
+4 FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.5,"AQ",PSOD))
if 'PSOD
QUIT
FOR PSOP=0:0
SET PSOP=$ORDER(^PS(52.5,"AQ",PSOD,PSOP))
if 'PSOP
QUIT
FOR PSOIN=0:0
SET PSOIN=$ORDER(^PS(52.5,"AQ",PSOD,PSOP,PSOIN))
if 'PSOIN
QUIT
Begin DoDot:1
+5 IF PSOD'=$PIECE($GET(^PS(52.5,PSOIN,0)),"^",2)
KILL ^PS(52.5,"AQ",PSOD,PSOP,PSOIN)
End DoDot:1
MW ;Update routing field in Pending File
+1 DO BMES^XPDUTL("Updating routing field...")
+2 NEW PAT,INST,PIEN,NODE,RELIN,PSOINZ
+3 FOR PAT=0:0
SET PAT=$ORDER(^PS(52.41,"AOR",PAT))
if 'PAT
QUIT
FOR INST=0:0
SET INST=$ORDER(^PS(52.41,"AOR",PAT,INST))
if 'INST
QUIT
FOR PIEN=0:0
SET PIEN=$ORDER(^PS(52.41,"AOR",PAT,INST,PIEN))
if 'PIEN
QUIT
SET NODE=$GET(^PS(52.41,PIEN,0))
IF $PIECE(NODE,"^",2)
IF $PIECE(NODE,"^",17)=""
Begin DoDot:1
+4 SET $PIECE(^PS(52.41,PIEN,0),"^",17)="M"
+5 SET ^PS(52.41,"AC",$PIECE(NODE,"^",2),"M",PIEN)=""
End DoDot:1
+6 ;Updating Institution field
+7 DO BMES^XPDUTL("Updating Institution field...")
+8 FOR PSOINZ=0:0
SET PSOINZ=$ORDER(^PS(59,PSOINZ))
if 'PSOINZ
QUIT
SET RELIN=$PIECE($GET(^PS(59,PSOINZ,"INI")),"^")
IF RELIN
Begin DoDot:1
+9 IF $ORDER(^PS(59,PSOINZ,"INI1",0))
QUIT
+10 SET ^PS(59,PSOINZ,"INI1",0)="^59.08P^1^1"
+11 SET ^PS(59,PSOINZ,"INI1",1,0)=RELIN
+12 SET ^PS(59,PSOINZ,"INI1","B",RELIN,1)=""
End DoDot:1
+13 DO BMES^XPDUTL("Indexing ACL cross reference...")
+14 NEW PSODA,PSOPT,PSOPIN,PSONODE
+15 FOR PSOPT=0:0
SET PSOPT=$ORDER(^PS(52.41,"AOR",PSOPT))
if 'PSOPT
QUIT
FOR PSOPIN=0:0
SET PSOPIN=$ORDER(^PS(52.41,"AOR",PSOPT,PSOPIN))
if 'PSOPIN
QUIT
FOR PSODA=0:0
SET PSODA=$ORDER(^PS(52.41,"AOR",PSOPT,PSOPIN,PSODA))
if 'PSODA
QUIT
Begin DoDot:1
+16 SET PSONODE=$GET(^PS(52.41,PSODA,0))
+17 IF $PIECE(PSONODE,"^",3)=""!($PIECE(PSONODE,"^",12)="")!($PIECE(PSONODE,"^",13)="")!($PIECE(PSONODE,"^",2)="")
QUIT
+18 IF $PIECE(PSONODE,"^",3)'="NW"
IF $PIECE(PSONODE,"^",3)'="RNW"
IF $PIECE(PSONODE,"^",3)'="RF"
QUIT
+19 SET ^PS(52.41,"ACL",+$PIECE(PSONODE,"^",13),+$PIECE(PSONODE,"^",12),PSODA)=""
End DoDot:1
+20 QUIT
IDNODE ; resets ^DD(52,0,"ID",6) node PSO*7*25
+1 ;
+2 DO BMES^XPDUTL("Resetting DD(52,0,""ID"",6) Node...")
+3 SET ^DD(52,0,"ID",6)="W:$D(^(0)) "" ""_$S($D(^PSDRUG(+$P(^(0),U,6),0))#2:$P(^(0),U,1),1:"""")_$E(^PSRX(+Y,0),0)_$S($P($G(^PSRX(+Y,""STA"")),U)=13:"" ***MARKED FOR DELETION***"",1:"""")"
+4 KILL ^DD(55,0,"P"),^DD(55,0,"PS")
+5 QUIT
PEND ;Delete invalid Renewal cross references
+1 DO BMES^XPDUTL("Updating 'AQ' cross reference...")
+2 NEW PSOPN,PSOPNI
+3 FOR PSOPN=0:0
SET PSOPN=$ORDER(^PS(52.41,"AQ",PSOPN))
if 'PSOPN
QUIT
FOR PSOPNI=0:0
SET PSOPNI=$ORDER(^PS(52.41,"AQ",PSOPN,PSOPNI))
if 'PSOPNI
QUIT
IF $PIECE($GET(^PS(52.41,PSOPNI,0)),"^",3)="DC"!($PIECE($GET(^(0)),"^",3)="DE")
KILL ^PS(52.41,"AQ",PSOPN,PSOPNI)
+4 QUIT
SUBF ;hanging sub-file 59.30001 removal
+1 SET DIU=59.30001
SET DIU(0)="S"
if $DATA(^DD(DIU))
DO EN^DIU2
KILL DIU
+2 QUIT
