- 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 Feb 18, 2025@23:59: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
